Tech Arsenal 1/Tech Arsenal (Arsenal Computer).ISO/tek-03/qbs-0101.zip/QBS-0101.DOC

Text File | 1993-01-04 | 218KB | 6,110 lines

------------------------------------------------------------------------
  The QuickBASIC Scrapbook                                    QUIK_BAS

  Vol 1, Issue 1                                          January 1993
------------------------------------------------------------------------

          QuickBASIC Scrapbook is produced by Quantum Software
                   (C)Copyright 1993 by Lee Madajczyk
                      Licensed to Quantum Software


       *** ALL INFORMATION CONTAINED IN THE QUICKBASIC SCRAPBOOK
           IS PUBLIC DOMAIN. ALL INFORMATION COMPILED IN THIS
           SCRAPBOOK WAS ORIGINALLY POSTED ON THE QUIK_BAS ECHO,
           FIDO-NET SYSTEMS. DATE, TIME, AND AUTHOR'S NAME HAVE
           BEEN PRESERVED.




       Special thanks to all those who have contributed or have
           a published letter or reply. Without your help, this
           would not have been possible.


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
                           Editor's Article

   Welcome to The QuickBASIC Scrapbook! QBS is a publication devoted
 to providing you with the most up-to-date information available, by
 using the QUIK_BAS echo of FidoNet and compiling important messages
 and programs posted in QUIK_BAS echo. Quantum Software distribution
 sites are listed in the file DISTSITE.QS. If you would like to
 become a distribution site, please see SITE_APP.QS. Thank you for
 your co-operation. Due to a time crunch, I cannot provide an index
 or table of contents. One will be included in the nest issue. An
 index for this issue may also be distributed with the next issue.
 Remember! A disk subscription is available for only $19.95! This
 subscription not only gives you the normal six issues ONE WEEK
 ahead of BBS releases, but gives you a special seventh issue not
 released to the public. Subscription information can be found in
 the SUBSCRBE.QBS file.

   This Month: Rich Geldreich's PC-Speaker MOD player, registration
      encoding, errorlevel reading, loading PCX files, existing file
      check, and more!

   Thank you for getting this file!

 Contact Information:

 U.S. Mail                          Netmail:
    Quantum Software                   Lee Madajczyk
    Lee Madajczyk                      Infinity (1:280/5)
    8012 Cottonwood
    Lenexa, KS  66215-4165             [phone]
    ATTN: QB Scrapbook                 Kansas City, MO


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
                     P r o d u c t   R e v i e w

                              UI4QB

  UI4QB is the ultimate in user interfaces! After reviewing the program
  for only a few days, I must say it is nothing short of impressive. Of
  course, I did register the program back in August, but I thought that
  it would be best to review it for you anyway. Microsoft originally
  made the program, but it was for the PDS system. Author William Cobb
  then redeveloped the program and set it up for use with QuickBASIC.
  I have called Microsoft many times and they assured me that William
  Cobb's switching between languages and releasing the program is
  completely legal. The number for you to call is [phone]. Press
  (2) for Developer's Assistance. I am assuming that you are at least
  halfway familiar with the QuickBASIC interface. Cobb's UI4QB can make
  you program use menus that look just like QB's. You can also

            * Change colors of the menus

            * Open multiple, moving windows

            * Use built-in mouse support

            * Supports B/W and EGA / VGA systems

            * Interface with the DOS directories

            * Pop up option boxes, shadowed boxes

            * More!

   The only problem I had with UI4QB was reading the manual. The manual
   can stand a little refinement, but as it stands it is fine. Seasoned
   programmers can easily pick up on the variables, while the newer
   people may have trouble. At first. You get use to it. Trust me. I
   should know. The author is rumored to be working on a new release.
   The registration price? Only 15 dollars. The current version is
   UI4QB 1.1a, and can be F'REQed from:

      Infinity  [phone]                (1:280/5)

                        Filename:  UI4QB11A.*


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
═════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #19212
 Date:    12-05-92 12:47 (Public)
 From:    JOHN GALLAS
 To:      SUNNY HUGHES
 Subject: Bload File Format?
─────────────────────────────────────────────────────────────────────
SH>Does anyone have the format for a Bsaved file... From what I understand
SH>from the on-line help in QB, you should be able to load in a Bsaved file
SH>from and standard I/O device minus the keyboard. What I'm trying to do is
SH>send a Bsaved file with a binary protocol throught the modem and read it
SH>and load it and display it on the remote end. I know I'd have to parse
SH>the input for the beginning of the file then load it, but from there I'm
SH>lost. Does this even sound like a god idea or can someone come up with a
SH>more efficient way of doing it without having to resort to a the remote
SH>user having to have all the Bsaved files on their end with the terminal?

Sure..

The first 7 bytes are some kind of BSave signature that you can ignore.
Then the next 4000 bytes are the actual screen.  2000 bytes for the
text, and 2000 bytes for the colors.  The first of the 4000 (8th in the
file) is the character in the upper left hand corner.  The next byte is
that charactes attribute.  Then the next character, and its attribte.
Heres some code to read in a bsave file and print it to the screen:

open "filename" for binary as #1

x$ = space$(7)  'make a dummy buffer to read in the first 7 bytes
get #1,,x$   'read it in and don't do anything with it

x$=" "  'now set the buffer size to 1 byte
pointer = 0  'the screen pointer we're using

def seg = &HB800  'b000 for mono

do until eof(1)

  get #1,,x$
  poke pointer, asc(x$)
  pointer=pointer+1

loop
def seg

close #1

This should be pretty slow (*definatly* waaay slower than Bload) but it
will get the job done.  Another thing you could consider doing is saving
the 4000 screen bytes into an array of integers, and then using a
movbytes routine to print them to the screen *instantly*.  I think Mark
Butler posted a movbytes routine, you can ask him for it if you're
interested.


 * OLX 2.1 TD * Do you expect my opinion to be swayed by mere PROOF?
--- RyPacker v2.5b
 * Origin: The Ghost Mode - An RyBBS System!  (612)-688-0026 (1:282/3006)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #19480
 Date:    12-06-92 08:44 (Public)
 From:    EARL MONTGOMERY
 To:      ALL
 Subject: Animation
────────────────────────────────────────────────────────────────────────────────
' Here is another version of a previous post. This one includes a text
' scroll:
DEFINT A-Z: SCREEN 7: CLS : x = 60: pg = -1: v = 118: h = 30: up = 23
Q$ = "E2U2R1U4H2R3U1D1R2U1D1R3G2D4R1D2F2L10"
n$ = "E2U1E2U2G2L1H1U1E4R3F2D4G1D2F2L10"
start:
FOR c = 0 TO 7
x = x + 1: h = h + 1: pg = pg + 1: up = up - 1
IF up < 5 THEN up = 23
IF pg + 1 = 8 THEN PCOPY 7, 0: pg = 0
SCREEN , , pg + 1, pg
COLOR 2: CLS
LOCATE 2, 2: COLOR 3: PRINT "Demo Of Animation Using Page Flipping"
LOCATE up, 10: COLOR 1: PRINT "Chess Pieces In The Sky"
DRAW "BM=" + VARPTR$(x) + ",=" + VARPTR$(v)
DRAW "s8;C8;X" + VARPTR$(Q$): PAINT (x + 4, v - 2), 4, 8
DRAW "BM=" + VARPTR$(h) + ",=" + VARPTR$(v)
DRAW "C8;X" + VARPTR$(n$): PAINT (h + 4, v - 2), 15, 8
FOR z = 0 TO 20
PSET (RND * 320, RND * 200), RND * 15
IF x > 300 THEN GOTO holdscrn
NEXT: NEXT
GOTO start
holdscrn:
GOTO holdscrn
'E N D
Earl

--- Maximus 2.01wb
 * Origin: Rabbit and Snake's BBS - Richardson, Texas (1:124/6108)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #19971
 Date:    12-05-92 15:30 (Public)
 From:    ANDY C. OLIVER
 To:      ALL
 Subject: MOUSEQB
────────────────────────────────────────────────────────────────────────────────
'COPIED FROM COMPUTE APRIL 1992 PG 52
'ENTERED BY A. CHRISTOPHER OLIVER FOR SUPERLINK BBS.
'YOU NEED TO LOAD THIS TO THE BEGINNING OF YOUR PROGRAM.
'OR MAKE IT A LIBRARY
'SUPERLINK BBS - [phone] FRI-MON
DEFINT A-Z
'$INCLUDE QB.BI
DECLARE SUB HIDEMOUSE ()
DECLARE SUB SHOWMOUSE ()
DECLARE SUB GETMOUSECORD (K%, K3%, M4%)
DECLARE SUB STARTMOUSE ()
DIM SHARED Inregs AS RegType, Outregs AS RegType

STARTMOUSE

DO
  GETMOUSECORD K, X, Y
  LOCATE 1,1
  PRINT X, Y, K
LOOP WHILE K=0

HIDEMOUSE
END

SUB GETMOUSECORD (K%, M3%, M4%)
Inregs.ax%=3
CALL INTERRUPT(&H33, Inregs, Outregs)
M3%=Outregs.cx% /8+1
M4%=Outregs.dx% /8+1
K%=Outregs.bx%
END SUB

SUB HIDEMOUSE
Inregs.ax%=2
CALL INTERRUPT(&H33, Inregs, Outregs)
END SUB

SUB SHOWMOUSE
Inregs.ax=1
CALL INTERRUPT(&H33, Inregs, Outregs)
END SUB

SUB STARTMOUSE
Inregs.ax%=0
CALL INTERRUPT(&H33, Inregs, Outregs)
Mouseinitialize%=Outregs.ax%
END SUB


--- TMail v1.31
 * Origin: Cornucopia TBBS - Winter Park, FL - 407/645-4929 (1:363/18)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #3771
 Date:    11-21-92 13:45 (Public)
 From:    SCOTT DRYSDALE
 To:      JIM COYLE
 Subject: Existing File check
────────────────────────────────────────────────────────────────────────────────
Hi.


 JC> fucntion Exist% (FileName$)
 JC>        open Filename$ for binary as #1
 JC>        if lof(1)=0 then

I use the EXACT same function exept mine uses FREEFILE so as to not disrupt
anything that might be open at the time.


--- Maximus 2.01wb
 * Origin: The BULLpen BBS * Intel 14.4EX [phone] (1:249/140)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #4284
 Date:    11-21-92 07:05 (Public)
 From:    FRANKLIN BEAL
 To:      BILL CAMPBELL
 Subject: Randmizing
────────────────────────────────────────────────────────────────────────────────
BC>can anyone help me. i wrote a program to randamize numbers, but it
  >keeps repeating the number such as, i type the number 3 and i want it
  >to randamize 1-3 but it will put maybe 1 2 2. so can anyone tell me how
  >to solve my problem?????
  >thanks,
  >bill campbell

Try this:

DO
   DO: x$ = INKEY$: LOOP UNTIL x$ <> ""

   IF x$ = CHR$(27) THEN END

   IF VAL(x$) > 0 THEN
      RANDOMIZE TIMER
      x% = INT(VAL(x$))*RND+1
      PRINT x%
   END IF
LOOP

If you want to add a lower limit to the generated number, the following
will work.

DO
   INPUT "Lower Limit? "; LBound%
   IF LBound% <= 0 THEN END
   INPUT "Upper Limit? "; UBound%

   RANDOMIZE TIMER
   x% = INT((LBound% - UBound%) + 1)*RND+LBound%
      PRINT x%
   END IF
LOOP

L8R
Franklin Beal

 * SLMR 2.0 * Anything worth fixing is worth doing right the first time


--- WM v2.04/91-0012
 * Origin: Com-Dat BBS  Hillsboro, OR.  HST [phone] (1:105/314)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #4331
 Date:    11-22-92 00:30 (Public)
 From:    PETE DUDESEK
 To:      MICHAEL BAILEY
 Subject: Variable Sharing in QB45
────────────────────────────────────────────────────────────────────────────────
 > combnations of COMMON SHARED, DIM SHARED, and SHARED statements with
 > each of the modules and subs, and the variables still aren't being
 > shared back up to the module level and across to other modules.

 > Anyone know what I'm doing wrong, or am I trying to handle this

I had the same problem recently and here is how I do it now.

This is a simple little test program for you to use to see how
to pass variables in modules. Just cut each one out and save
them as a seperate files. COMMON.INC, DECLARE.INC, MAIN.BAS,
SUB1.BAS, SUB2.BAS, and SUB3.BAS.

Now load up QB and load in MAIN.BAS. Then with File/Load command
Load in SUB1.BAS, SUB2.BAS and SUB3.BAS.

Now run the program to see it work at passing to and from.

' ----- save this as COMMON.INC --------
' These are all the common shared variables to be used
' by MAIN.BAS, SUB1.BAS, SUB2.BAS, SUB3.BAS

   COMMON SHARED Global1$, Global2$, Global3$
   COMMON SHARED Global1%, Global2%, Global3%
   COMMON SHARED Global4$()

   DIM SHARED Global4$(10)

   Global1$ = "This is the Global1$"
   Global2$ = "This is the Global2$"
   Global3$ = "This is the Global3$"

   Global1% = 1
   Global2% = 2
   Global3% = 3

   FOR Z% = 1 TO 10

      Global4$(Z%) = "This is array Global4$ " + STR$(Z%)

   NEXT Z%
'----- End of COMMON.INC -----

'----- Save this as DECLARE.INC -----
' This is the common declare file to be used with
' MAIN.BAS, SUB1.BAS, SUB2.BAS, SUB3.BAS
DECLARE SUB Sub1Sub ()
DECLARE SUB Sub2Sub ()
DECLARE FUNCTION Sub3Function% (Tmp$)
DECLARE FUNCTION Sub3Function4$ (Tmp AS INTEGER)
'----- End of DECLARE.INC -----

'----- Save as MAIN.BAS -----
' This is a simple test program
' This is the main module called MAIN.BAS
' $INCLUDE: 'DECLARE.INC'
' $INCLUDE: 'COMMON.INC'

CLS

PRINT
PRINT "We are in the main Module"
PRINT

Sub1Sub

Sub2Sub

PRINT Sub3Function(Test$)
PRINT Test$
PRINT

PRINT "Press a key to see the Global4$() array passing test"
DO: LOOP WHILE INKEY$ = ""

FOR X% = 1 TO 10
PRINT Sub3Function4$(X%)
NEXT X%
END
'----- End of MAIN.BAS -----

'----- Save as SUB1.BAS -----
DECLARE SUB Sub1Sub ()
' This is SUB1.BAS
' $INCLUDE: 'DECLARE.INC'
' $INCLUDE: 'COMMON.INC'

SUB Sub1Sub
PRINT "Coming to you from SUB1.BAS - SUB Sub1Sub"
PRINT Global1$
PRINT
END SUB

'----- End of SUB1.BAS -----

'----- Save as SUB2.BAS -----
' This is SUB2.BAS
' $INCLUDE: 'DECLARE.INC'
' $INCLUDE: 'COMMON.INC'

Sub2Sub

SUB Sub2Sub
PRINT "Coming to you from SUB2.BAS - SUB Sub2Sub"
PRINT Global2$, Global2%
PRINT
END SUB

'----- End of SUB2.BAS -----

'----- Save as SUB3.BAS -----
' This is SUB3.BAS
' $INCLUDE: 'DECLARE.INC'
' $INCLUDE: 'COMMON.INC'

FUNCTION Sub3Function% (Tmp$)
PRINT "Coming to you from SUB1.BAS - FUNCTION Sub3Functiuon%"
Sub3Function% = Global3%
Tmp$ = Global3$
END FUNCTION

FUNCTION Sub3Function4$ (Tmp%)
Sub3Function4$ = Global4$(Tmp%)
END FUNCTION

'----- End of SUB3.BAS -----

Note: That if you create a new FUNCTION in one of the sub modules
remember to create a declare statement for it and put it in the
DECLARE.INC. Same goes for SUB's, even though QB automatically
adds a DECLARE SUB to your MAIN Module.

Hope it helps you out.


--- Squish v1.01
 # Origin: UBU-Midwest - Bensenville IL - 708-766-1089  (8:7401/13)
 * Origin: FamilyNet Intl. Echogate [708] 887-7685 (1:115/887)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #4334
 Date:    11-21-92 11:21 (Public)
 From:    DIK COATES
 To:      TRENT SHIRLEY
 Subject: registration encodin
────────────────────────────────────────────────────────────────────────────────
>>>> QUOTING Trent Shirley to Dik Coates <<<<

 TS> means, and I know NOTHING about Algorithms.

Trent, an algorithm is simply a method of formulating a problem
and solving it.  The algorithm for dividing a pile of pennies equally
might be as simple as putting 1 into each of two pockets until the pile has
disappeared...(hoping you have no remainder)...

 TS> Even given exact code, would it not still be nearly
 TS> impossible to crack the unknown algorithm?  That is what I

It is not impossible, meerly very difficult...Because the sample (the amount
of encrypted text is small, it is more difficult), combined with the fact
that two different encryption techniques are used, and the results blended
help make it very difficult...It is always possible to go into the program
code and unravel the encryption techniques, but if your application is
sensitive enough that totally bulletproof encryption is required, you should
be working it out with a cryptographic programmer.  I have some DES stuff, and
a bunch of PD source for encryption...for C or Assembly programming or linking
libraries.  If I can find it in my box of goodies, can put it on line, but
from your introductory comments...you might have some problem with it...

 TS> was hoping for anyway.  Possibly some mostly useful code,
 TS> with enough info to formulate my own algorithm.

I can upload some of my earlier stuff that can be used... half a dozen
routines for rotating and shuffling bit values (all done in BASIC) if that
will help...but by publishing it, your own approach will be less secure!
Gimme the word, and I'll put it on line...  The following is a bit of an
example of what can be done...your imagination is the only thing stopping
you!

An approach you can take is to to take the name... convert each character to
an ASCII value and write the ASCII value in binary form.  For example 'A' has
an ASCII value of 65 which has a binary value of 01000001.  This binary number
can be rotated 3 to the left yielding the binary value 00001010 which is the
same ASCII value 10 which corresponds to the symbol of 'a dark square with a
small white o in the centre'.  The same letter 'A' can be rotated 4 characters
to the left yielding a binary number 00010100 which is the same as ASCII value
20 yielding the symbol that looks like 'an uppercase backwards P'.  These
values
can be written to a binary file and someone not knowing the method of
encryption
will not be able to decypher the letters A and A.  The program can read the
first symbol and convert it back to an 'A' and then read the second sysbol and
convert it to an 'A' and compare the values...if they are the same, no one has
tampered with the encrypted file...I hope you can follow this so far...tried
to
make it as clear as I can.

The method of encryption above is fairly simple, but unless someone knows the
technique, they will have difficulty 'breaking' the code.  It can be made much
more complicated simply by making the amount it shifted to the left dependent
on the letter, so they all shift different amounts, or the value shifted can
depend on the character in front or behind.

Another approach is to take the binary value and separate every second bit
value and combine the two halves.  For example 1 0 1 1 0 0 1 0 becomes
                                               ^   ^   ^   ^
                                               1 1 0 1 and 0 1 0 0
so 10110010 becomes 1101 0100.

Hope I haven't confused you too badly...will post some simple stuff if you
want.

 TS> I was just hoping for something a bit generic that would be
 TS> applicable.

There may be some PD encryption routines in BASIC out there, but I'm not
familiar with them.  Regards Dik

 TS>  ! Origin: Pioneer Valley PCUG1 (1:321/109)

Where's this at?

... Damn touchscreen, Anyone see my braille tagline... -Dik
--- Blue Wave/QWK v2.10

--- Maximus 2.00
 * Origin: Durham Systems (ONLINE!) (1:229/110)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #3934
 Date:    11-21-92 23:08 (Public)
 From:    RICH GELDREICH
 To:      ALL
 Subject: Asm Fader/fix 1                                               (ASM)
─────────────────────────────────────────────────────────────────────────────
Ooops! After looking back at the ASM fader I posted a few days ago, I
discovered that I posted the wrong one! Duh! Well, here is the one I
originally wanted to post. The ASM code follows. Next message has OBJ
and test program.

;Noiseless VGA DAC fading routines for QB4.5/PDS(works on 286's and up)
;By Rich Geldreich 1992
;Assembled with TASM v2.0
.286
IDEAL
MODEL SMALL
DATASEG
Palette    db 768 dup (?)
NewPalette db 768 dup (?)
CODESEG
PUBLIC GetPalette, SetPalette
EVEN
PROC    SetPalette              ;Sets the pallette retrieved by
                                ;GetPalette to a specified brightness
;DECLARE SUB SetPalette (BYVAL Brigtness, BYVAL Start, BYVAL Num)
Brightness EQU [ss:bp+10] ;0-128
Start      EQU [ss:bp+08] ;0-255
Num        EQU [ss:bp+06] ;1-256
Parameters = 3
        Push    bp              ;set us up a stack frame
        Mov     bp, sp
        Push    es ds si di     ;lets not get QB mad now
        Mov     ax, @data       ;get access to palette buffers
        Mov     ds, ax
        Mov     es, ax
        Xor     ax, ax
        Mov     al, Start       ;get start color
        Mov     dx, 03C7h       ;tell the VGA some DAC values will
        Out     dx, al          ;be coming
        Inc     dx
        Out     dx, al
        Inc     dx              ;dh=3
        Mov     si, ax          ;add start*3 to the palette offset
        Shl     si, 1
        Add     si, ax
        Add     si, offset Palette
        Mov     bl, Brightness
        Cmp     bl, 128         ;limit brightness if too high
        Jna     @@Ok1
        Mov     bl, 128
@@Ok1:
        Mov     cx, Num         ;CX=# of registers to change
        Jcxz    @@Done          ;if no registers to change then exit
        Add     ax, cx          ;calculate the last register to change
        Sub     ax, 256         ;if too many then limit
        Jna     @@OK2
        Sub     cx, ax
@@OK2:
        Mov     di, offset NewPalette
        Mov     bp, cx          ;save cx for later
EVEN                            ;color precalculation loop
@@10:   REPT    3               ;repeat 3 times(for Red, Green, & Blue)
        Lodsb                   ;
        Mul     bl              ;new=old*brightness
        Shl     ax, 1           ;new=(new*2)\256 or new=new\128
        Mov     al, ah
        Stosb
        ENDM
        Loop    @@10
        Mov     cx, bp          ;multiply number of colors by 3
        Shl     cx, 1
        Add     cx, bp
        Mov     si, offset NewPalette
        Mov     dl, 0DAh        ;wait for vertical retrace
@@15:   In      al, dx          ;wait for end of vertical retrace
        Test    al, 8           ;(for very fast machines)
        Jnz     @@15
@@20:   In      al, dx          ;now wait for start of vertical
        Test    al, 8           ;retrace
        Jz      @@20
        Mov     dl, 0C9h        ;dx=03C9h
        Rep     Outsb           ;output the new colors
@@Done:
        Pop     di si ds es bp
        Retf    Parameters*2    ;bye bye
ENDP    SetPalette
PROC    GetPalette              ;Must call this routine before
;DECLARE SUB GetPalette ()      ;SetPalette!
        Push    es
        Mov     ax, @data
        Mov     es, ax
        Mov     dx, offset Palette ;es:dx addresses palette
        Mov     cx, 256
        Xor     bx, bx
        Mov     ax, 01017h
        Int     010h
        Pop     es
        Retf    0
ENDP    GetPalette
END

--- MsgToss 2.0b
 * Origin: Computer Co-Op - Voorhees, NJ | Ted Hare (1:266/29)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #4061
 Date:    11-21-92 19:35 (Public)
 From:    BRENT ASHLEY
 To:      RAYMOND PAQUIN
 Subject: QB SIMULTANEOUS KEYS                                          (ASM)
─────────────────────────────────────────────────────────────────────────────
;
; KeyPress.ASM by Brent Ashley
;   maintains map of  the "pressed" status of all keys
;   allows you to detect multiple keys pressed
;
.model medium, basic
.code
Old09        Label Dword          ;Label for to old Int 09h handler
Old09Offset  dw ?                 ;Offset part
Old09Segment dw ?                 ;Segment part
Hooked       db 0                 ;Our installed flag
KeyMap       db 80h dup(0)        ;map of kybd, one byte per scancode

InstKeyPress proc uses ds ax dx   ; From BASIC: CALL InstKeyPress
                                  ; REMEMBER to call UnhookKeyPress!
        cmp cs:Hooked,0           ;Are we already hooked?
        jnz InstallExit           ;If so, exit
        mov ax,3509h              ;Get current vector for int 09h
        int 21h
        mov cs:Old09Segment,es    ;Remember it for later
        mov cs:Old09Offset,bx
        mov ax,2509h
        push ds
        push cs
        pop ds                    ;Point int 09h handler to our code
        mov dx, offset OurInt09
        int 21h
        pop ds
        mov cs:Hooked,-1          ;Set our installed flag

InstallExit:
        ret

OurInt09:                         ;Our Int 09h handler
        push ax
        push bx
        push dx
        push si

        in al, 60h                ;get scancode from keyboard port
        test al, 080h             ;is "released" bit set?
        jnz Released              ;yup - go to it
        mov dl, 0FFh              ;nope - set key pressed flag
        jmp PutFlag

Released:
        and al, 07Fh              ;yes - clear bit for index
        mov dl, 0                 ;and set flag for release

PutFlag:
        xor ah, ah
        mov si, ax                ;assign index
        mov cs:KeyMap[si], dl     ;put flag in place

        pop si
        pop dx
        pop bx
        pop ax

Continue:
        jmp dword ptr cs:[Old09]  ;Transfer control to orig Int 09h
InstKeyPress endp

KeyPressed proc uses bx si, ScanCode:WORD
        ; from BASIC: TrueOrFalse% = KeyPressed(ScanCode%)
        mov bx, ScanCode          ;get scan code addr
        mov si, [bx]              ;load value as index

        mov al, cs:KeyMap[si]     ;put flag in al
        and al, 07Fh              ;make sure less than 80h
        cbw                       ;convert to word for integer value
        ret
KeyPressed endp

UnhookKeyPress proc               ; from BASIC: CALL UnHookKeyPress
        cmp cs:Hooked,0           ; are we installed?
        jz UnHooked               ; nope - exit

        push ax
        push ds
        mov ax,2509h              ;Unhook ourself
        mov ds,Old09Segment
        mov dx,Old09Offset
        int 21h                   ;Point Int 09h back to original
handler
        pop ds
        pop ax
        mov cs:Hooked,0           ;Set installed flag back to zero

UnHooked:
        ret
UnhookKeyPress endp
END
--- FidoPCB v1.3 [ff053/x]
 * Origin: Canada Remote Systems, Mississauga, Ontario  (1:229/15)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #4068
 Date:    11-21-92 22:40 (Public)
 From:    MATHIEU BOUCHARD
 To:      ALL
 Subject: VGA graphics/Palette
────────────────────────────────────────────────────────────────────────────────
Here is my LIGHTNING FAST palette writer...

load QB.QLB...

$include:'qb.bi'
dim rin as regtypex
dim rout as regtypex

dim pal as string * 768

...

'to change palette: c=color, r=red 0-63, g=green 0-63, b=blue 0-63
mid$(pal,c*3+1,3)=chr$(r)+chr$(g)+chr$(b)

'after all your changes, let's update:
rin.ax=&h1012:rin.bx=0:rin.cx=256:rin.dx=varptr(pal):rin.es=varseg(pal)
interruptx &h10,rin,rout


--- Maximus 2.01wb
 * Origin: R&D BBS, [phone] HST/V32 (Line 2) (1:163/506)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #5003
 Date:    11-21-92 11:14 (Public)
 From:    PETER BARNEY
 To:      MARK THOMAS
 Subject: Error Level
────────────────────────────────────────────────────────────────────────────────
Try this (you must load QB.QLB or QBX.QLB for this to work)


'$INCLUDE 'QB.BI'    '<- qbx.bi for pds.

SUB ExitProgram (s)
'Exits the program with an errorlevel.  Instead of END, use
'ExitProgram <int> where <int> is the error level you wish
'to exit with

DIM Regs AS RegType
Regs.ax = &H4C00 + (s AND 255)
CALL Interrupt(&H21, Regs, Regs)
END SUB

--- FMail 0.92
 * Origin: Pete's Place - Toledo, Ohio (1:234/35.1)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #5004
 Date:    11-21-92 11:29 (Public)
 From:    PETER BARNEY
 To:      MARK THOMAS
 Subject: Networking....Share
────────────────────────────────────────────────────────────────────────────────
 >     When running on a network, I get a share violation.
 >     Can anyone suggest a way that I can prevent this problem

OPEN "filename.ext" FOR RANDOM ACCESS <access> <lock> AS #1 LEN=whatever

Replace <access> with:
       Read     Opens the file for reading only.
      Write     Opens the file for writing only.
 Read Write     Opens the file for both reading and writing.
                (This mode works only on random and binary files,
                and files opened for append.)

Replace <lock> with:
          Shared    Any process on any machine can work with the
                    file.
       Lock Read    No other process can read the file.  (this
                    access is granted only if no other process has
                    a previous read access to the file.
      Lock Write    No other process is granted write access to this
                    file.  This lock is granted only if no other
                    process has a previous write access to the file.
 Lock Write Read    No other process is granted either read or write
                    write acess to the file.  This access is granted
                    only if read or write access has not been already
                    granted to another process, or if a lock read or
                    lock write is not already in place.

hope this helps!

--- FMail 0.92
 * Origin: Pete's Place - Toledo, Ohio (1:234/35.1)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #5450
 Date:    11-28-92 20:08 (Public)
 From:    LEE MADAJCZYK
 To:      JAMES FRAZEE
 Subject: PCX Load SUB
────────────────────────────────────────────────────────────────────────────────
 JF>   Is there a program to convert .PCX into a .BSV file. I found
 JF> out finally how easy it is too BLOAD a .BSV file and If I can
 JF> convert a .PCX into a .BSV it would be easier.
 JF>
 JF>   Now if someone can give me code to load a 16 color .PCX file
 JF> as a menu for a game,let me know,please.

Here you go.... (I stole this from SOMEWHERE....)

     'PCX SAVE & PCX LOAD FOR EGA SCREEN 9 (640 x 350, 16 COLOR)
     'BY G.C.HARDER, RE-ENGINEERED FROM C SOURCE IN
     ' "FRACTAL PROGRAMMING IN C"

     DEFINT A-Z
     DECLARE SUB PCXSave (File$, Pal.Array%())
     DECLARE SUB PCXLoad (File$, Pal.Array%())

     FileName$ = "Demo4.PCX"
     SCREEN 9, 0, 1, 0
     DIM Pal.Array%(15)
     FOR I% = 0 TO 15: READ Pal.Array%(I%): NEXT
     CLS
     LOCATE 25, 30: PRINT "Loading " + FileName$;

     PCXLoad FileName$, Pal.Array%()
     'default Palette Colors
     DATA 0,1,2,3,4,5,20,7,56,57,58,59,60,61,62,63


SUB PCXLoad (File$, Pal.Array%()) STATIC
        SCREEN 9, 0, 0, 0: OPEN File$ FOR BINARY AS #1: SEEK #1, 17
        DIM Byte AS STRING * 1
        FOR I% = 0 TO 15
           GET #1, , Byte: red% = ASC(Byte) / 85
           GET #1, , Byte: green% = ASC(Byte) / 85
           GET #1, , Byte: Blue% = ASC(Byte) / 85
           red% = ((red% AND 1) * 32) OR ((red% AND 2) * 2)
           green% = ((green% AND 1) * 16) OR (green% AND 2)
           Blue% = ((Blue% AND 1) * 8) OR ((Blue% AND 2) \ 2)
           Hue% = red% OR green% OR Blue%: Pal.Array%(I%) = Hue%
        NEXT
        PALETTE USING Pal.Array%(0): SEEK #1, 129: DEF SEG = &HA000
        FOR k% = 0 TO 349
           A$ = INKEY$: IF A$ = CHR$(27) THEN END
           Addr% = 80 * k%: Line.end% = Addr% + 80: J% = 1
           DO WHILE J% <= 4
              B% = J%
              IF J% = 3 THEN B% = 4
              IF J% = 4 THEN B% = 8
              OUT &H3C4, 2: OUT &H3C5, B%
              GET #1, , Byte: Byte.1% = ASC(Byte)
              IF (Byte.1% AND 192) <> 192 THEN
                 POKE Addr%, Byte.1%: Addr% = Addr% + 1
                 IF Addr% >= Line.end% THEN Addr% = 80 * k%: J% = J% + 1
              ELSE
                 Byte.1% = Byte.1% AND 63
                 GET #1, , Byte: Byte.2% = ASC(Byte)
                 FOR M% = 1 TO Byte.1%
                    B% = J%
                    IF J% = 3 THEN B% = 4
                    IF J% = 4 THEN B% = 8
                    OUT &H3C4, 2: OUT &H3C5, B%: POKE Addr%, Byte.2%
                    Addr% = Addr% + 1
                    IF Addr% >= Line.end% THEN Addr% = 80 * k%: J% = J% + 1
                 NEXT
              END IF
           LOOP
        NEXT
        OUT &H3C4, 2: OUT &H3C5, &HF: DEF SEG ': CLOSE #1

     END SUB


Hope this helps. After you load your file, just BSAVE it. If you
want the PCX saving routine, or anyone else for that matter, give
me a ring!

                                    Lee Madajczyk
                                    Quantum Software

... OFFLINE 1.40 * Difference between a virus & Windows? Viruses don't fail.
---
 * Origin:  Infinity   -=[HST]=- (1:280/5)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #5543
 Date:    11-23-92 19:07 (Public)
 From:    STEVE GARTRELL
 To:      ROBERT CHURCH
 Subject: QB/PDS/VBDOS INT Handlers
────────────────────────────────────────────────────────────────────────────────
'So Basic can't do interrupt handlers...The DemRegs variable
'passes back the status of the registers at the time of the
'interrupt.  Likewise, if you change a DemRegs.(anyreg)
'value inside the handler sub, that value will be placed
'in the respective register!!!  Dangerous toy, A?  The
'global variable Busy% is read inside the Absolute array
'ASM; if it's <> 0 then the routine chains directly (mostly)
'to the original vector.  Which you will want, if you are going
'to DEF SEG out of DGROUP, for instance!!!
'NOT FOR USE IN THE ENVIRONMENT!!  Compile it, and then
'let it run for 20 or 30 seconds, and you'll start seeing the
' registers passed back...
'
'This is _not_ a toy...If you are not sure what you are doing,
' try thinking about worst-case scenarios, and take proper
' preventative measures...Like, if you play with disk access
' interrupts, BACK UP!!

'Compiled and tested under QB45 and PDS...
DEFINT A-Z
'$INCLUDE: 'VBDOS.BI'   'QB.BI if using QB4.5, QBX.BI in PDS
DECLARE SUB Handler ()
'remark out the original DECLARE SUB Absolute declaration in your
' include file; it's modified here...
DECLARE SUB Absolute (RegsOff%, Busy%, OldSeg%, OldOff%,_
 StartPtr%, address AS INTEGER)
'bet ya can't guess what my middle initial is...
TYPE SKGregs
  ax AS INTEGER
  bx AS INTEGER
  cx AS INTEGER
  dx AS INTEGER
  si AS INTEGER
  di AS INTEGER
  es AS INTEGER
  ds AS INTEGER
  flags AS INTEGER
  bp AS INTEGER
END TYPE

CONST C$ = "Created 08/31/92 by Steve Gartrell."
'don't want this stuff moving around!!!  These
' MUST remain global!!!
'$STATIC
DIM SHARED AsmArray%(1 TO 88), DemRegs AS SKGregs
DIM SHARED OldOff%, OldSeg%, RetToAsm%, RegsOff%, SetUp%
DIM SHARED TicCnt%, Busy%
'$DYNAMIC
CLS
LOCATE 1, 70: PRINT LEFT$(TIME$, 8)

SetUp% = VARPTR(AsmArray%(47))
RetToAsm% = VARPTR(AsmArray%(29))
NewSeg% = VARSEG(AsmArray%(1))
NewOff% = VARPTR(AsmArray%(1))
RegsOff% = VARPTR(DemRegs)

DIM Regs AS RegTypeX

'DOS get interrupt vector using the clock 08h for
' demo purposes...Can use any other, too, but be
' aware that results can be extremely dependent
' upon what QB/PDS has done/is gonna do with the
' original vector!!!
Regs.ax = &H3508
CALL INTERRUPTX(&H21, Regs, Regs)
'save 08h original vector
OldSeg% = Regs.es
OldOff% = Regs.bx
'read all the sneaky little ASM opcodes in, which are primarily
' concerned with register saving, and navigating around the
' flow "limitations" imposed by QB/PDS...
RESTORE
FOR Word% = 1 TO 88
  READ DataStr$
  AsmArray(Word%) = VAL(DataStr$)
NEXT

'Call the sub that sets up necessary address calculations...

Handler   'OldSeg% & OldOff% are global, remember...

'Use DOS set interrupt call to change interrupt &H08 vector to
' the one returned for the AsmArray code that resides in DGROUP...
Regs.ax = &H2508
Regs.ds = NewSeg%
Regs.dx = NewOff%
CALL INTERRUPTX(&H21, Regs, Regs)

cnt& = 0
DO
  'gotta do something to show clock is interrupt driven
  ' Fix Busy% true, and the interrupt-driven time
  ' print can occur before this LOCATE and PRINT finish,
  ' with the number then showing up at coordinate 2,1!!
  cnt& = cnt& + 1
  Busy% = -1
  LOCATE 5, 35
  PRINT cnt&;
  Busy% = 0
  IF cnt& > 2000000 THEN cnt& = 1
LOOP UNTIL LEN(INKEY$)

'Return INT &H08 to it's original vector-THIS MUST ALWAYS
' BE DONE!!!
Regs.ax = &H2508
Regs.ds = OldSeg%
Regs.dx = OldOff%
CALL INTERRUPTX(&H21, Regs, Regs)

LOCATE 24, 1

END 'This is the end, my FIDO friend, the end...

'88 WORDS, FIRST call at VARPTR(47), LAST call at VARPTR(29)
ReversedOpcodes:

DATA &H8B55,&H9CEC,&H061E,&H5657,&H5152,&H5053,&HD78C,&HDF8E
DATA &H90BB,&H8B90,&H2307,&H75C0,&H8E30,&H8BC7,&HFCF4,&H90BF
DATA &HB990,&H000A,&HA5F3,&HEF83,&H5714,&HEE83,&H5614,&HB8FB
DATA &H9090,&HB850,&H9090,&HCB50,&HC483,&H8C0E,&H8ED7,&H8EDF
DATA &H5FC7,&HFC5E,&H0AB9,&HF300,&H58A5,&H595B,&H5E5A,&H075F
DATA &H9D1F,&H2E5D,&H2EFF,&H0058,&H9090,&H9090,&H8B55,&H50EC
DATA &H5253,&H8B56,&H065E,&H1F8B,&HEB83,&H8B5C,&H0246,&H0305
DATA &H8900,&H3487,&H8B00,&H0446,&H8789,&H0030,&HF38B,&H5E8B
DATA &H8B08,&H8917,&H5894,&H8B00,&H0A5E,&H178B,&H9489,&H005A
DATA &H5E8B,&H890C,&H119C,&H8B00,&H0E5E,&H178B,&H9489,&H001F
DATA &HC68B,&H5805,&H8900,&H5644,&H5A5E,&H585B,&HCA5D,&H000A

REM $STATIC
STATIC SUB Handler ()

SHARED OldOff%, OldSeg%, RetToAsm%, RegsOff%, SetUp%
SHARED TicCnt%, Busy%, DemRegs AS SKGregs, NewOff%

'Make sure we're looking at DGROUP
DEF SEG

CALL Absolute(RegsOff%, Busy%, OldSeg%, OldOff%, SetUp%, SetUp%)
EXIT SUB

'This routine's LIFE DEPENDS UPON a certain amount of
' code bytes between the EXIT SUB and the next command
' (happens to be JGE [IF < THEN] here, but not critical).  IF
' YOU SPECIFY /D(ebug) when compiling, YOUR system will HANG!!
' ('Cuz the compiler will sneak some stuff in in between
'  the EXIT SUB and your first line of code!!!)  Also, ERROR
' handling (/E/X compile options) in QB is probably
' impossible, and should be approached with care in PDS (like,
' anything but LOCAL error handling is probably out of the
' question, and LOCAL in this sub is a no-no!!!)
' Put any code you want between the EXIT SUB and the
' DEF SEG...EXCEPT (at least) END or it's equivalents...
' You MUST return the clock to it's original vector before
' exiting to DOS, SHELLing, and so forth!!!

'update if 10 seconds have elapsed AND it's safe to do so!

IF TicCnt% < 10 THEN
  TicCnt% = TicCnt% + 1   'a little delay...
ELSE
  Busy% = -1
  LOCATE 1, 70
  PRINT LEFT$(TIME$, 8)  'update the time
  LOCATE 2, 1
  'print the register values at interrupt...
  ' Remember, if you change a register variable at
  ' this point, it _will_ change the register contents!!
  PRINT "AX = "; HEX$(DemRegs.ax); "h"; SPACE$(4)
  PRINT "BX = "; HEX$(DemRegs.bx); "h"; SPACE$(4)
  PRINT "CX = "; HEX$(DemRegs.cx); "h"; SPACE$(4)
  PRINT "DX = "; HEX$(DemRegs.dx); "h"; SPACE$(4)
  PRINT "SI = "; HEX$(DemRegs.si); "h"; SPACE$(4)
  PRINT "DI = "; HEX$(DemRegs.di); "h"; SPACE$(4)
  PRINT "ES = "; HEX$(DemRegs.es); "h"; SPACE$(4)
  PRINT "DS = "; HEX$(DemRegs.ds); "h"; SPACE$(4)
  PRINT "BP = "; HEX$(DemRegs.bp); "h"; SPACE$(4)
  PRINT "Flags = "; HEX$(DemRegs.flags); "h"; SPACE$(4)
  TicCnt% = 1
  Busy% = 0
END IF

DEF SEG
CALL Absolute(dummy%, dummy%, dummy%, dummy%, dummy%, RetToAsm%)

END 'I stuck this END in here just to show you that
   ' the instruction pointer will never get here...

END SUB


--- D'Bridge 1.30/071082
 * Origin: RadioLink! Columbus, OH [phone] HST/DS (1:226/140)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #5544
 Date:    11-23-92 19:08 (Public)
 From:    STEVE GARTRELL
 To:      ROBERT CHURCH
 Subject: QB/PDS/VBDOS INT Handlers
────────────────────────────────────────────────────────────────────────────────
      .model medium, basic

      .code

handle  PROC
IntEntry:

  push    bp                      ; push everything
  mov     bp, sp                  ; stack frame
  pushf
  push    ds
  push    es
  push    di
  push    si
  push    dx
  push    cx
  push    bx
  push    ax


  mov     di, ss                  ;cuz the damned data seg
  mov     ds, di                  ; can get lost

BusyOff:
  mov     bx, 9090h
  mov     ax, [bx]
  and     ax, ax
  jnz     SHORT TooBusy

  mov     es, di                  ;point dest seg at DGROUP
  mov     si, sp                  ;stack address for regs to si
  cld

RegsOff:
  mov     di, 9090h               ;QB/PDS reg TYPE offset to di

  mov     cx, 0Ah
  rep     movsw

  sub     di, 14h
  push    di
  sub     si, 14h
  push    si
  sti

HandSeg:
  mov     ax, 9090h               ;Here the QB sub segment
  push    ax                      ; is placed on the stack for the
          ; RETF
HandOff:
  mov     ax, 9090h               ;Here the QB sub offset
  push    ax                      ; is placed on the stack for the
  retf                            ; RETF

AllDone:

  add     sp, 0Eh                 ;roll the stack ptr back past the
          ; last CALL Absolute far return
          ; address and the five dummy
          ; variables on the stack.  Then
          ; pop everything

  mov     di, ss                  ;cuz the damned data seg
  mov     ds, di                  ; can get lost
  mov     es, di

  pop     di                      ;popped in reverse dest/source
  pop     si

  cld
  mov     cx, 0Ah
  rep     movsw

TooBusy:
  pop     ax
  pop     bx
  pop     cx
  pop     dx
  pop     si
  pop     di
  pop     es
  pop     ds
  popf
  pop     bp
  jmp     cs:OldInt

JmpAddr:

OldInt  DD      90909090h

Start:
  assume  ds:seg IntEntry
  push    bp                      ; set up stack frame ptr
  mov     bp, sp
  push    ax
  push    bx
  push    dx
  push    si
  mov     bx, [bp + 6]            ;get ptr to start of this handler
          ; (stored in DGROUP)
  mov     bx, [bx]
  sub     bx, Start - IntEntry

  mov     ax, [bp + 2]            ; get QB sub return offset
  add     ax, 03h                 ; add 3 to compensate for JMP
          ;  opcode/disp and store in code

  mov     WORD PTR [bx + HandOff + 1], ax

  mov     ax, [bp + 4]            ; get QB sub return seg
          ;  and store in code

  mov     WORD PTR [bx + HandSeg + 1], ax

  mov     si, bx                  ;preserve start of code ptr

  mov     bx, [bp + 8]            ;original int offset ptr to DX
  mov     dx, WORD PTR [bx]       ; and moved to code storage
  mov     WORD PTR [si + JmpAddr], dx

  mov     bx, [bp + 0Ah]          ;original int segment ptr to DX
  mov     dx, WORD PTR [bx]       ; and moved to code storage
  mov     WORD PTR [si + JmpAddr + 2], dx

  mov     bx, [bp + 0Ch]          ;busy flag ptr offset to DX
          ; and moved to code storage
  mov     WORD PTR [si + BusyOff + 1], bx

  mov     bx, [bp + 0Eh]          ;SKGregs ptr to DX, adj to end,
  mov     dx, WORD PTR [bx]       ; and moved to code storage
  mov     WORD PTR [si + RegsOff + 1], dx

  mov     ax, si                  ;start of code ptr in AX
  add     ax, JmpAddr - IntEntry  ;add distance to offset of OldInt
          ; and move to actual JMP opcode
  mov     [si + (JmpAddr - IntEntry) - 2], ax

  pop     si
  pop     dx
  pop     bx
  pop     ax
  pop     bp
  retf    0Ah                     ;return clearing stack
          ; of five ptr words

handle  ENDP

  END     ;this is the end, my FIDO friend, the end...


--- D'Bridge 1.30/071082
 * Origin: RadioLink! Columbus, OH [phone] HST/DS (1:226/140)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #5673
 Date:    11-21-92 15:01 (Public)
 From:    RICHARD DALE
 To:      TRENT SHIRLEY
 Subject: Registration Encoding
────────────────────────────────────────────────────────────────────────────────
TS>Im looking for information on implementing REGISTRATION codes into my
software.
TS> The best method I KNOW of is using an algorithm that will encode the
persons
TS>name and BBS name, then sending back the code to the person and tell them
to

This isn't exactly what you're looking for, as it can't be done by the
individual user.

ChkSum = 0
ValidSum = 2874
Tst$ = Copyright1$
FOR I% = 1 TO LEN(Tst$)
    ChkSum = ChkSum + ASC(MID$(Tst$, I%))
NEXT I%
PRINT ChkSum
'IF ChkSum <> ValidSum THEN CALL LeaveProgram

For example, Copyright1$ could be "Joe Blow 689453".  Run this, taking
the value ChkSum returns and put it in the second line.  Then delete
the line PRINT ChkSum and unremark the last line.

Anyone using a hex editor to change copyright notices will change the
value in ChkSum, and the program will terminate.

 * 1st 1.01 #567 * Pardon me, but would you have any Blue Poupon?
--- FidoPCB v1.2 [ff013/c]
 * Origin: Sound Advice - 24 Nodes [phone] (1:280/333)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #5993
 Date:    11-21-92 18:06 (Public)
 From:    TONY ELLIOTT
 To:      PETER BARNEY
 Subject: Truncating Files
────────────────────────────────────────────────────────────────────────────────
Peter,

 PB> Is there an easy way in QB to truncate a file to a certain length
 PB> without copying it?

Sure .. Not directly via QB, but through an interrupt call. As long as
the file is opened for RANDOM, BINARY or OUTPUT, this should work fine.
I wrote it for QBX, but it'll work fine for other version by changing
the $INCLUDE to QB.BI for VBDOS.BI.

    DECLARE FUNCTION TruncateFile% (Handle%, NewLength&)
    DEFINT A-Z
    REM $INCLUDE: 'qbx.bi'
    OPEN "TEST.DAT" FOR BINARY AS #1        'Create a file to test
    A$ = " "
    PUT #1, 10240, A$                       'Make it 10K long
    PRINT "File length:"; LOF(1)            'Make sure
    Handle% = FILEATTR(1, 2)                'Get DOS file handle
    NewLength& = 5000                       'New length for this file
    Status% = TruncateFile%(Handle%, NewLength&)    'Do it
    IF Status% THEN
        PRINT "DOS Error";Status%;" occurred."
    ELSE
        PRINT "New file length:"; LOF(1)
    END IF
    CLOSE

FUNCTION TruncateFile% (Handle%, NewLength&)

    DIM Reg AS RegTypeX

    'First, position the file read/write pointer to the place where the
    'truncation should take place. We can't trust BASIC's SEEK statement
    'because the movement is sometimes held until the next read/write.

    Reg.AX = &H4200             'DOS "Set file pointer" function
    Reg.BX = Handle%

    'We go through these steps to prevent "overflow" errors when
    'NewLength& > 32767. The high word of the file position goes in CX
    'and the low word goes in DX. Since BASIC treats integers and longs
    '"signed" variables, we need to take to extra steps to prevent
    'an overflow error as we break the long integer down.

    DEF SEG
    Addr% = VARPTR(NewLength&)
    Reg.CX = CVI(CHR$(PEEK(Addr% + 2)) + CHR$(PEEK(Addr% + 3)))
    Reg.DX = CVI(CHR$(PEEK(Addr%)) + CHR$(PEEK(Addr% + 1)))
    CALL InterruptX(&H21, Reg, Reg)
    IF Reg.Flags AND 1 THEN
        Status% = Reg.AX
        GOTO TruncateExit
    END IF

    'Now, write 0 bytes.
    Reg.AX = &H4000                 'Dos "Write file or device"
    Reg.BX = Handle%
    Reg.CX = 0                      'Write 0 bytes
    Reg.DX = 0                      'These are not needed, but make
    Reg.DS = 0                      ' sure they're zero, just in case
    CALL InterruptX(&H21, Reg, Reg)
    IF Reg.Flags AND 1 THEN
        Status% = Reg.AX
    END IF

TruncateExit:
    TruncateFile% = Status%

END FUNCTION

... Okay, I pulled the pin. What now? Where are you going?
--- Blue Wave/Max v2.10 [NR]
 * Origin: Oakland BBS - McDonough, GA - [phone] (1:133/706.0)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #6039
 Date:    11-23-92 22:35 (Public)
 From:    RICH GELDREICH
 To:      HARVEY PARISIEN
 Subject: Gif Decompression Sys
────────────────────────────────────────────────────────────────────────────────
'Cheap, no frills GIF decompressor for the VGA's 320x200x256 mode.
'By Rich Geldreich 1992 (Public domain, use as you wish.)
'Sorry for no documentation, I wanted to crunch it to 150 lines...
DEFINT A-Z
DIM Prefix(4095), Suffix(4095), OutStack(4095), ShiftOut(8)

'The following line is for the QB environment(slow).
DIM Ybase AS LONG, Powersof2(11) AS LONG, WorkCode AS LONG
'For more speed, unremark the next line and remark the one above,
'before you compile... (Change back when inside the environment.)
'DIM Ybase AS INTEGER, Powersof2(11) AS INTEGER, WorkCode AS INTEGER

FOR A = 0 TO 7: ShiftOut(8 - A) = 2 ^ A: NEXT
FOR A = 0 TO 11: Powersof2(A) = 2 ^ A: NEXT
A$ = COMMAND$: IF A$ = "" THEN INPUT "GIF file"; A$: IF A$ = "" THEN END
IF INSTR(A$, ".") = 0 THEN A$ = A$ + ".gif"
OPEN A$ FOR BINARY AS #1
A$ = "      ": GET #1, , A$
IF A$ <> "GIF87a" THEN PRINT "Not a GIF87a file.": END
GET #1, , TotalX: GET #1, , TotalY: GOSUB GetByte
NumColors = 2 ^ ((A AND 7) + 1): NoPalette = (A AND 128) = 0
GOSUB GetByte: Background = A
GOSUB GetByte: IF A <> 0 THEN PRINT "Bad screen descriptor.": END
IF NoPalette = 0 THEN P$ = SPACE$(NumColors * 3): GET #1, , P$
DO
    GOSUB GetByte
    IF A = 44 THEN
        EXIT DO
    ELSEIF A <> 33 THEN
        PRINT "Unknown extension type.": END
    END IF
    GOSUB GetByte
    DO: GOSUB GetByte: A$ = SPACE$(A): GET #1, , A$: LOOP UNTIL A = 0
LOOP
GET #1, , XStart: GET #1, , YStart: GET #1, , XLength: GET #1, , YLength
XEnd = XStart + XLength: YEnd = YStart + YLength: GOSUB GetByte
IF A AND 128 THEN PRINT "Can't handle local colormaps.": END
Interlaced = A AND 64: PassNumber = 0: PassStep = 8
GOSUB GetByte
ClearCode = 2 ^ A
EOSCode = ClearCode + 1
FirstCode = ClearCode + 2: NextCode = FirstCode
StartCodeSize = A + 1: CodeSize = StartCodeSize
StartMaxCode = 2 ^ (A + 1) - 1: MaxCode = StartMaxCode

BitsIn = 0: BlockSize = 0: BlockPointer = 1
X = XStart: Y = YStart: Ybase = Y * 320&

SCREEN 13: DEF SEG = &HA000
IF NoPalette = 0 THEN
    OUT &H3C7, 0: OUT &H3C8, 0
    FOR A = 1 TO NumColors * 3: OUT &H3C9, ASC(MID$(P$, A, 1)) \ 4: NEXT
END IF
LINE (0, 0)-(319, 199), Background, BF
DO
    GOSUB GetCode
    IF Code <> EOSCode THEN
        IF Code = ClearCode THEN
            NextCode = FirstCode
            CodeSize = StartCodeSize
            MaxCode = StartMaxCode
            GOSUB GetCode
            CurCode = Code: LastCode = Code: LastPixel = Code
            IF X < 320 THEN POKE X + Ybase, LastPixel
            X = X + 1: IF X = XEnd THEN GOSUB NextScanLine
        ELSE
            CurCode = Code: StackPointer = 0
            IF Code > NextCode THEN EXIT DO 'bad GIF if this happens
            IF Code = NextCode THEN
                CurCode = LastCode
                OutStack(StackPointer) = LastPixel
                StackPointer = StackPointer + 1
            END IF

            DO WHILE CurCode >= FirstCode
                OutStack(StackPointer) = Suffix(CurCode)
                StackPointer = StackPointer + 1
                CurCode = Prefix(CurCode)
            LOOP

            LastPixel = CurCode
            IF X < 320 THEN POKE X + Ybase, LastPixel
            X = X + 1: IF X = XEnd THEN GOSUB NextScanLine

            FOR A = StackPointer - 1 TO 0 STEP -1
                IF X < 320 THEN POKE X + Ybase, OutStack(A)
<<-to be continued on next message->>

--- MsgToss 2.0b
 * Origin: Computer Co-Op - Voorhees, NJ | Ted Hare (1:266/29)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #6040
 Date:    11-23-92 22:39 (Public)
 From:    RICH GELDREICH
 To:      HARVEY PARISIEN
 Subject: A Gif decoder/p2
────────────────────────────────────────────────────────────────────────────────
<<Part 2 Starts Here>>
                X = X + 1: IF X = XEnd THEN GOSUB NextScanLine
            NEXT

            IF NextCode < 4096 THEN
                Prefix(NextCode) = LastCode
                Suffix(NextCode) = LastPixel
                NextCode = NextCode + 1
                IF NextCode > MaxCode AND CodeSize < 12 THEN
                    CodeSize = CodeSize + 1
                    MaxCode = MaxCode * 2 + 1
                END IF
            END IF
            LastCode = Code
        END IF
    END IF
LOOP UNTIL DoneFlag OR Code = EOSCode
BEEP
A$ = INPUT$(1)
END

GetByte: A$ = " ": GET #1, , A$: A = ASC(A$): RETURN

NextScanLine:
    IF Interlaced THEN
        Y = Y + PassStep
        IF Y >= YEnd THEN
            PassNumber = PassNumber + 1
            SELECT CASE PassNumber
            CASE 1: Y = 4: PassStep = 8
            CASE 2: Y = 2: PassStep = 4
            CASE 3: Y = 1: PassStep = 2
            END SELECT
        END IF
    ELSE
        Y = Y + 1
    END IF
    X = XStart: Ybase = Y * 320&: DoneFlag = Y > 199
RETURN
GetCode:
    IF BitsIn = 0 THEN GOSUB ReadBufferedByte: LastChar = A: BitsIn = 8
    WorkCode = LastChar \ ShiftOut(BitsIn)
    DO WHILE CodeSize > BitsIn
        GOSUB ReadBufferedByte: LastChar = A
        WorkCode = WorkCode OR LastChar * Powersof2(BitsIn)
        BitsIn = BitsIn + 8
    LOOP
    BitsIn = BitsIn - CodeSize
    Code = WorkCode AND MaxCode
RETURN
ReadBufferedByte:
    IF BlockPointer > BlockSize THEN
        GOSUB GetByte: BlockSize = A
        A$ = SPACE$(BlockSize): GET #1, , A$
        BlockPointer = 1
    END IF
    A = ASC(MID$(A$, BlockPointer, 1)): BlockPointer = BlockPointer + 1
RETURN

<<-Cut Here->>

    There you go!

    This is a more efficient version of my first GIF decoder... It can
decode 320x200x256 GIFs at an acceptable speed(MUCH faster than my
original decoder), but there are still a few optimizations I left out to
keep it simple.

    Rich

--- MsgToss 2.0b
 * Origin: Computer Co-Op - Voorhees, NJ | Ted Hare (1:266/29)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #7056
 Date:    11-24-92 21:34 (Public)
 From:    JIM HARRE
 To:      TOM HAMMOND
 Subject: HELP!  Unsigned #'s
────────────────────────────────────────────────────────────────────────────────
In a message of <19 Nov 92  19:40:00>, Tom Hammond (1:289/15) writes:

 >I was confused that the value of this variable appeared to be a negative
 >number.  Looking into the actual file, I found that the two bytes were
 >&H73 and &H84.  I assumed that the two bytes were stored LOW HIGH, so I
 >reversed their position and ran them through a HEX-to-DEC calculator to
 >obtain a confirmation of what I'd previously printed out.  The
 >calculated value was 33907....  NOT the -31629 I'd come to expect.
 >
 >Now I'm REALLY confused!  Would anyone care to lend a helping hand and

Remember that QB is always going to assume an integer is signed, that's why
you got -31629.  Try this:

     num% = &H8473            'your number
     PRINT num%               'shows -31629
     IF num% < 0 THEN         'QB thinks it is a signed variable
          PRINT num% + 65536  'shows 33907
     END IF

Hey, there's your magic 33907!  Of course you can't store that in an integer
since the maximum value for a signed short integer is +32767.  You CAN
straighten it out with a long integer like this:

     num% = &H8473
     lnum& = num%
     IF lnum& < 0 THEN lnum& = lnum& + 65536
     PRINT lnum&

Moving between signed and unsigned numbers can be hazardous to the health of
your hair!  {-)

     <*> Jim


--- QM v1.00
 * Origin: * EMC/80 * St Louis MO [phone] -=<HST/ds>=- (1:100/555.0)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #7574
 Date:    11-19-92 04:22 (Public)
 From:    WALTON DELL
 To:      DAVID KOUTS
 Subject: Paint Program
────────────────────────────────────────────────────────────────────────────────
 -=> Quoting David Kouts to All <=-

 DK> I'm kind of an amateur QBASIC programmer who likes to do a
 DK> lot with graphics. I'm working on a (kind-of) drawing program, and was
 DK> wondering if anyone could tell me how I could get input from a mouse?
 DK> What commands would I use?

Here's a very simple paint program:

'This doesn't work with DOS 5 QBasic!
DEFINT A-Z
'$INCLUDE: 'QB.BI'  'do DIR \QB.BI /s if you need path
DECLARE SUB PrintScrn ()
DECLARE SUB MouseNow (leftbutton%, rightbutton%, xmouse%, ymouse%)
DECLARE SUB MouseShow ()
DECLARE SUB MouseHide ()

SUB MouseHide
DIM InRegs AS RegType, OutRegs AS RegType
InRegs.ax = 2
Interrupt 51, InRegs, OutRegs
END SUB

SUB MouseNow (leftbutton%, rightbutton%, xmouse%, ymouse%)
DIM InRegs AS RegType, OutRegs AS RegType
InRegs.ax = 3: leftbutton% = 0: rightbutton% = 0
Interrupt 51, InRegs, OutRegs
IF OutRegs.bx = 1 THEN leftbutton% = -1
IF OutRegs.bx = 2 THEN rightbutton% = -1
IF OutRegs.bx = 3 THEN leftbutton% = -1: rightbutton% = -1
xmouse% = OutRegs.cx: ymouse% = OutRegs.dx
END SUB

SUB MouseShow
DIM InRegs AS RegType, OutRegs AS RegType
InRegs.ax = 1
Interrupt 51, InRegs, OutRegs
END SUB

SUB PrintScrn
DIM InRegs AS RegType, OutRegs AS RegType
Interrupt 5, InRegs, OutRegs
END SUB

SCREEN 0, 0, 0, 0: CLS : COLOR 3: MouseShow
DO
  MouseNow Left, Right, x, y
  IF Left THEN
    MouseHide
    LOCATE y, x: PRINT CHR$(219);
    MouseShow
  ELSEIF Right THEN
    MouseHide
    LOCATE y, x: PRINT " ";
    MouseShow
  END IF
  KeyPress$ = UCASE$(INKEY$)
  IF KeyPress$ = "P" THEN PrintScrn
LOOP UNTIL KeyPress$ = "Q"
MouseHide
END

 DK> I'm having to do all my programming on a word-processor and
 DK> taking it to my grandparent's house to test it, since this dinky 256k
 DK> computer of mine won't run QB. Is there any way I can get QB to run on
 DK> this thing?

  Not that I know of, but I'd HIGHLY recommend that you either upgrade
your memory, find a cheap (less than $15) XT motherboard (at least) if
you have IBM compatible parts, or buy a whole new system.

Walton Dell

P.S. I love to help beginners.


... Misspelled?  No way!  I have an error-correcting modem.
    Blue Wave/QWK v2.10


--- WM v2.01/92-0162
 * Origin: The Huff & Puff BBS (602)-996-0033 USR DS (1:114/144)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #7733
 Date:    11-23-92 14:49 (Public)
 From:    JOHN GALLAS
 To:      MIKE KERR
 Subject: Preserving orig. COMMAND$
────────────────────────────────────────────────────────────────────────────────
MK>The problem I'm having now, is similar, yet not.  Sorry, I won't be
MK>cryptic any more! :-)   I have just written a program that will print

MK>C:\QBASIC\PP.BAS
MK>Which is EXACTLY what I want.  I get this from MID$(COMMAND$,4).  So,
MK>what's the problem?  When I compile the program, all that gets read in
MK>is:
MK>QBASIC\PP.BAS

<etc etc>

Heres a routine that'll use interrupts to read in the command line
entered from DOS.  It shouldn't take off any characters, and it even
preserves upper/lower case.


'=================================================================
'Date: 04-11-91
'From: BRENT ASHLEY
'Subj: ORIGINAL COMMAND LINE; preserving lower case
'Conf: QBASIC (62)

'The command line as entered at the DOS prompt, in all its mixed-case
'splendour, is found at offset &H81 of the program's PSP (Program Segment
'Prefix), with the length of the command string at offset &H80 of the
'PSP.
'
'Finding your PSP from within QuickBASIC entails Interrupt calls.
'   ~~~~~~~~~
'That same area of the PSP, however, is also the default disk transfer
'area for the program (or is it the default File Control Block? - I don't
'have my references handy) At any rate, I suspect QB always defines its
'own DTAs and FCBs, so the data won't be overwritten, but this cannot
'always be guaranteed.  It would be best, therefore, if you were to get
'this info, to get it as early in the program's execution as possible,
'especially before any file I/O.
'======================================================================

DECLARE FUNCTION CmdLine$ ()
DEFINT A-Z
' $INCLUDE: 'qb.bi'

PRINT "Here's the original command line:"
PRINT "["; CmdLine$; "]"

END

FUNCTION CmdLine$
  '
  ' CmdLine - returns original command line
  '
  DIM Regs AS RegType
  STATIC CmdLen, CmdBuild$, i
  '
  ' DOS Interrupt 21h service 62h returns the segment
  ' address of the running program's PSP in the bx register.
  '
  Regs.ax = &H6200
  CALL Interrupt(&H21, Regs, Regs)
  DEF SEG = Regs.BX
  '
  ' The command line's length is found at offset 80h of the PSP
  ' and the actual command line starts at 81h
  '
  CmdBuild$ = ""
  CmdLen = PEEK(&H80)
  FOR i = 1 TO CmdLen
    CmdBuild$ = CmdBuild$ + CHR$(PEEK(&H80 + i))
  NEXT
  '
  ' restore BASIC data segment and return data
  '
  DEF SEG
  CmdLine$ = CmdBuild$
END FUNCTION

The only problem is, you can't change the command line from within the
QB environment, but if you're always running from an exe, it'll work
fine.

 * OLX 2.1 TD * I don't have a life, I have a BBS..
--- RyPacker v2.5b
 * Origin: The Ghost Mode - An RyBBS System!  (612)-688-0026 (1:282/3006)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #9093
 Date:    11-25-92 18:09 (Public)
 From:    GEORGE BATALIAS
 To:      DICK DENNISON
 Subject: 19200+
────────────────────────────────────────────────────────────────────────────────
DD>    > Are you doing 14.4 with OPEN COM?

DD>   JH> NAK! (G). QB's Open stops at 9600. Using a neat third-party gizmo
(th

DD>   NAK.  You can use OPEN to 19200,  Try it.  (And you can poke it to 115k
DD>   if you need to.)


Yea. Some of my DOORS run at 19200. Using qb45. Never saw them
run faster! Whats the secret? I don't use qbser or add on library. Just
straight qb code from CATPATCH.BAS part of it goes like this:

 IF baud = 2400 then
  bp$ = "2400"
' (cut out for shortness)
 IF baud = 19200 then
  bp$ = "19200"
  END IF

'baud is the baud rate passed from the bbs dropfile

'  maybe i could just add:


  IF baud = 38400 then
   bp$ = "38400"
  IF baud = 76800 then
   bp$ = ""76800"
  ' ETC up to 14,400

 open com1 + ":" + bp$ + par$ for random as #3

"Whad du ya think?"
I'm not to familiar with POKE, PEEK, INTERUPTS, ETC

   -----

For anyone else writing a door (or for outputing over the modem) that
doesn't want to spend the $$$ then i would recommend CATPATCH (uses
CALLINFO.BBS) or the new DPATCH (uses door.sys). Its FREE! Complete
source is included. (thats all there is,  QB code!). I have modified
this code and i am a beginner. Works like a charm!. I bet someone could
modify it even for ANSI music(over the modem).....(G)   any takers????

Well, anyway call Jim Brewers BBS (GULF COAST BBS)and you can get these
bas files ( i believe they are CATPATCH.ZIP and DPATCH.ZIP). He says he
doesn't support it anymore but they are there for DLD. (Thanks JIM!)

QB does go to 19200! ..... maybe more!
L8TR
                         GB

 * OLX 2.2 * CORVETTE BBS...1-702-431-2284...Las Vegas...FS files...


--- WM v2.04/91-0049
 * Origin: Reservation Only! Las Vegas,Nv~702-898-8630~ (1:209/721)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #9225
 Date:    11-25-92 13:24 (Public)
 From:    PETER BARNEY
 To:      MICHAEL BAILEY
 Subject: Variable Sharing in QB45
────────────────────────────────────────────────────────────────────────────────
 > Thanks for the response, but my problem is sharing a typed record
 > variable (ie COMMON SHARED RAC AS RACMAST, where RACMAST is a record
 > variable defined in a TYPE statement) between SUB proceedures in
 > different modules.

I couldn't find a problem... Try this:

'---------This is MODULE1.BAS---------
DECLARE SUB GetName ()
DECLARE SUB ChangeName ()

TYPE RacMast
    name    AS STRING * 10
    age     AS INTEGER
END TYPE

COMMON SHARED Rac AS RacMast

CALL GetName        'sub in this module

PRINT Rac.name
PRINT Rac.age
END

SUB GetName
    Rac.name = "peter"
    Rac.age = 20
    CALL ChangeName     'sub in other module
END SUB

'---------This is MODULE2.BAS---------
TYPE RacMast
    Name    AS STRING * 10
    Age     AS INTEGER
END TYPE

COMMON SHARED Rac AS RacMast

SUB ChangeName
    Rac.Name = "Mike"
    Rac.Age = 25
END SUB


As you can see, the SUB ChangeName changes the data in Rac and returns it to
the calling SUB GetName, which in turn returns it to the module-level code in
MODULE1.BAS

If I'm missing something, or you have more questions, let me know.

--- FMail 0.92
 * Origin: Pete's Place (1:234/35.1)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #10851
 Date:    11-26-92 14:25 (Public)
 From:    JOHN GALLAS
 To:      DAVE WILLIAMS
 Subject: Sequential Data Deletn
────────────────────────────────────────────────────────────────────────────────
DW> I am writing a program for a small business. It keeps a list ofrecords.
DW>Sometimes one or more records will need to be eliminated.
DW>Is there a way to delete individual records from a file?  And then
DW>renumber the remaining records?
DW>   Each record is for an account.  So each has its 1st variable as:
DW>  accnt.name   Could I have the program check to see if accnt.name
DW>  = space$(8), and if so delete that record?
DW>  Thanks for any help. I'm pretty new in Qbasic and this is obviouslya
DW>pretty `basic' question

The only way that I know of to delete records from a random file is to
read it in, and output a second file, like this:

OPEN "ACCOUNTS.DAT" FOR RANDOM AS #1 LEN = LEN(Accnt)
OPEN "$$$$ii$i.uuu" FOR RANDOM AS #2 LEN = LEN(Accnt)  'dummy file

TotalRecords = LOF(1) \ LEN(Accnt)

Count = 0

FOR x = 1 TO TotalRecords

  GET #1, x, Accnt
  IF Accnt.name <> SPACE$(8) THEN
     'if this record isn't blank then save it to the new file
     Count = Count + 1
     PUT #2, Count, Accnt
  END IF

NEXT x

CLOSE 1, 2

KILL "ACCOUNTS.DAT"
NAME "$$$$i$ii.uuu" AS "ACCOUNTS.DAT"

'now all the records with blank names should be gone.

 * OLX 2.1 TD * It's not "crippleware". It's "functionally challenged".
--- RyPacker v2.5b
 * Origin: The Ghost Mode - An RyBBS System!  (612)-688-0026 (1:282/3006)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #10994
 Date:    11-28-92 05:52 (Public)
 From:    DICK DENNISON
 To:      DAVID COLSTON
 Subject: 19200 baud in QB
────────────────────────────────────────────────────────────────────────────────
DD>NAK.  You can use OPEN to 19200,  Try it.  (And you can poke it to 115k
DD>if you need to.)

DC> Well, don't stop there. Please give details.

Use the straight OPEN COM statement for 19200.  To go higher you can
use this code (originally from Donn Bly):

SUB baudlatch   'enables 38400 baud  want to put in com3 and com4 support
'NewBaud$ = "38400"
'BaudNum% = 3   'for 38.4
'BaudNum% = 2  'for 56000
BaudNum% = 1 'for 115K


SELECT CASE Port$
        CASE "COM1:"
                BaseAddress% = &H3F8
        CASE "COM2:"
                BaseAddress% = &H2F8
        CASE "COM3:"
                BaseAddress% = &H3E8
        CASE "COM4:"
                BaseAddress% = &H2E8
END SELECT
        OldLSR% = INP(BaseAddress% + 3)
        OUT (BaseAddress% + 3), (OldLSR% OR &H80)   ' Enable the Divisor L
atch
        OUT (BaseAddress% + 0), (BaudNum% MOD &HFF) ' Lo Byte of Baud Rate
        OUT (BaseAddress% + 1), (BaudNum% \ &H100)  ' Hi Byte of baud Rate
        OUT (BaseAddress% + 3), OldLSR%             ' Disable Divisor Latc
h
END SUB
  'Sorry for the line wrap.  Enjoy.

--- VP [DOS] V4.09e
 * Origin: The MailMan  [phone] NY Quick Share Pt #7 *HST (1:272/34)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #12296
 Date:    11-29-92 23:10 (Public)
 From:    AARON LAPIKAS
 To:      LUKE MERRILL
 Subject: Ctrl-Alt-Del Trap
────────────────────────────────────────────────────────────────────────────────
> an educational game for children.  Can anyone give me a hint as to
> the best way to trap or disable the Ctrl-Alt-Del combination in QB.

Hi Luke!

I'm sure that this isn't the best way, and I'm sure that others will tell you
better ways of doing it, but my way will work.  Here is an example:

KEY 15, CHR$(&H04)+CHR$(38)     'Define a key for CTRL-ALT
KEY(15) ON                      'Turn the key on

ON KEY(15) GOSUB TrapKey

DO
LOOP                            'Idle loop, used just as an example


TrapKey:
                                'When the CTRL-ALT combination is pressed,
RETURN                          'the program branches to here, then returns
                                'to the program.


The only problem with this method is that the CAP-LOCK, SCROLL-LOCK, and NUM-
LOCK must be off.  However, you can POKE to certain memory locations and shut
them off at the beginning of your program in case they were on. Again, this
is not the best way to do this, but if no one else helps you, it's a starting
place.

Aaron

--- FMail 0.90
 * Origin: Send your Finleys and Hershisers to Sharon, PA. (1:2601/506.1)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #12646
 Date:    11-29-92 12:15 (Public)
 From:    RICK PEDLEY
 To:      SCOTT WUNSCH
 Subject: Accessing COM3/4:
────────────────────────────────────────────────────────────────────────────────
 On 11-27-92 Scott Wunsch wrote to All...

 SW> Salutations, All!
 SW>
 SW>   I seems to me that I've seen a post here about COM3/4.
 SW> All that was done was simply switching the addresses in low
 SW> memory, and then 3 & 4 became 1 & 2. ;) Does anybody still
 SW> have this?  Or at least have the PEEK/POKE addresses
 SW> necessary?

----------------------------------------------------------------------------
' DIAL    BAS : Dial a phone number on the screen
' author .....: Dick Dennison [74270,3636] 1:272/34 914-374-3903 *hst 24 hrs
' supports ...: COM1 - COM4
' syntax .....: DIAL portnum%
' includes ...: None
' notes ......: Move the cursor with the arrow keys to the phone number
'             : Press the spacebar and move the right arrow key across
'             : the number and press Enter
'             : Uses Basic's OPEN COMx commands
' cost .......: Free = Credit where credit due
'             : Do not use as is for commercial use - may not be resold
'             : May not be rebundled without prior written consent
' dated ......: 10/19/91,10/9/92
' credits ....: Thanks to Mike Welch for CLIPMSG, and Pete Petrakis for his
'             : notes on Com Port swapping.

DECLARE SUB Hangup (port%)
DECLARE SUB Getnum (row%, Col%, markit%, port%)
DECLARE SUB Setup (port%)

LOCATE 1, 1

doscolor% = SCREEN(1, 1, -1)
fg% = doscolor% AND &HF
bg% = doscolor% / &H10 AND 6   '&H7 - 1

COLOR 0, 7
LOCATE 24, 1
PRINT "     Move the cursor to the beginning of the phone number and press_
       Space       " 'line is wrapped
PRINT "                             DIALX from Dick Dennison";
GOTO Here
LOCATE 10, 1
IF VAL(COMMAND$) < 1 OR VAL(COMMAND$) > 4 THEN      'Get the portnum%
     PRINT "Port number must be on command line"
     END
ELSE port% = VAL(COMMAND$)
END IF
Here:
port% = 2          'Hard code the port here

'==================================================
'Setup some special key functions
CR$ = CHR$(13)
Nul$ = CHR$(0)
ArrowLt$ = Nul$ + CHR$(75)
ArrowRt$ = Nul$ + CHR$(77)
ArrowUp$ = Nul$ + CHR$(72)
ArrowDn$ = Nul$ + CHR$(80)
EndKey$ = Nul$ + CHR$(79)
Esc$ = CHR$(27)
BackSp$ = CHR$(8)
Home$ = Nul$ + CHR$(71)
SpaceBar$ = CHR$(32)
'===================================================

'Save vectors at bios Addresses for Com1-Com2
DEF SEG = 0
  OldPort1H = PEEK(&H400)
  OldPort1L = PEEK(&H401)
  OldPort2H = PEEK(&H402)
  OldPort2L = PEEK(&H403)
DEF SEG

'==================================================================
'Move cursor around
DO                         'This section lets the user move
 In$ = INKEY$             'move the cursor around on the screen
 SELECT CASE In$          'to the beginning of the phone number
  CASE CHR$(48) TO CHR$(57)
     numflag% = -1
     count% = count% + 1
     markit% = -1
     PRINT In$;
  CASE CR$
    IF markit% THEN       'A CR signals the end of the highlight
     row% = CSRLIN
     Col% = POS(0) - count%
    IF numflag% THEN count% = count% - 1
     EXIT DO
    END IF
  CASE Esc$                'END
    END
  CASE Home$               'Goto the beginning of the line
     LOCATE , 1
  CASE EndKey$             'Goto the end of the line
     LOCATE , 80
  CASE ArrowUp$            'UpArrow
     x% = CSRLIN
     IF x% > 1 THEN LOCATE x% - 1
  CASE ArrowDn$            'DownArrow
     x% = CSRLIN
     IF x% < 25 THEN LOCATE x% + 1
  CASE ArrowLt$                                 'LeftArrow
     IF POS(0) > 1 THEN LOCATE , POS(0) - 1
     IF markit% THEN count% = count% - 1       'If markit% then ' ' was
                                               ' pressed
  CASE ArrowRt$                             'RightArrow

     IF markit% THEN
          count% = count% + 1               'If markit% then ' ' was pressed
          row% = CSRLIN: Col% = POS(0)
          a% = SCREEN(row%, Col%)
          PRINT CHR$(a%);
     ELSE
          IF POS(0) < 80 THEN LOCATE , POS(0) + 1
     END IF
  CASE BackSp$
     IF POS(0) > 1 THEN         'Backspace with delete
         count% = count% - 1
         LOCATE , POS(0) - 1
         PRINT " ";
         LOCATE , POS(0) - 1
     END IF
  CASE SpaceBar$
     IF markit% THEN
          count% = count% + 1          'If markit% then ' ' was pressed
          row% = CSRLIN: Col% = POS(0)
          a% = SCREEN(row%, Col%)
          PRINT CHR$(a%);
     ELSE
          BEEP
          markit% = -1                      'Flag set for marking number
     END IF
 END SELECT
 LOCATE , , 1                   'Keep cursor flashing
LOOP
'======================================================================

         'Get the phone number off the screen
Getnum row%, Col%, count%, port%

         'Restore old vectors
CLOSE 1

'DEF SEG = 0
'   POKE &H400, OldPort1H
'   POKE &H401, OldPort1L
'   POKE &H402, OldPort2H
'  POKE &H403, OldPort2L
'DEF SEG

COLOR fg%, bg%
END

SUB Getnum (row%, Col%, markit%, port%)
GOTO Here1:
IF row% < 1 THEN row% = 1
IF Col% < 1 THEN Col% = 1
LOCATE row%, Col%
FOR x% = 0 TO markit%           'Read the phone number off the screen
     a% = SCREEN(row%, Col% + x%)
     Dialstr$ = Dialstr$ + CHR$(a%)
NEXT x%
Here1:
Dialstr$ = "544-1573"
LOCATE 23, 25
PRINT "        Dialing : "; Dialstr$; "        ";
LOCATE 25, 1

PRINT "         Pickup handset and then press space or ESC when phone rings_
                            "; 'line is wrapped
COLOR 7, 0

Setup port%
PRINT #1, "ATM1DP" + Dialstr$     'Dial the number
LOCATE 24, 1
DO
     b$ = INKEY$
     IF b$ = " " THEN
          Hangup port%
          EXIT DO
     END IF
     IF b$ = CHR$(27) THEN
          Hangup port%
          EXIT DO
     END IF
LOOP

END SUB

SUB Hangup (port%)

PRINT SPACE$(25) + "...Disconnecting 1";
SELECT CASE port%                'Drop DTR
    CASE 1
        OUT &H3FC, (INP(&H3FC) AND 254)   'com1
    CASE 2
        OUT &H2FC, (INP(&H2FC) AND 254)   'com2
'    CASE 3
'        OUT &H3FC, (INP(&H3FC) AND 254)   'com3
'    CASE 4
'        OUT &H2FC, (INP(&H2FC) AND 254)   'com4
END SELECT
     PRINT "...2...";
     PRINT #1, "+++";   'Switch to modem command mode if needed
     SLEEP 1
     PRINT #1, "ATH"    'Send hangup command
     PRINT "...CLICK" + SPACE$(22);

END SUB

SUB Setup (port%)
'Sets up the comport by swapping the address fo com4 with com2 and
'com3 with com1 if necessary
'DEF SEG = 0
' POKE &H400, &HF8
' POKE &H401, 3
' POKE &H402, &HF8
' POKE &H403, 2

SELECT CASE port%
     CASE 1
        Start$ = "COM1:2400,N,8,1,DS0"
     CASE 2
        Start$ = "COM2:2400,N,8,1,DS0"
     CASE 3
        POKE &H400, &HE8   'For com1 to com3
        Start$ = "COM1:2400,N,8,1,DS0"
     CASE 4
        POKE &H402, &HE8   'For com2 to com4
        Start$ = "COM2:2400,N,8,1,DS0"
END SELECT
'DEF SEG

OPEN Start$ FOR RANDOM AS 1

END SUB

___--------------------------------------------------------------------
... OFFLINE 1.40

--- Maximus 2.01wb
 * Origin: The BULLpen BBS * Intel 14.4EX [phone] (1:249/140)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #14193
 Date:    12-01-92 05:15 (Public)
 From:    JERRY ALDRICH
 To:      ALL
 Subject: Directory Tree
────────────────────────────────────────────────────────────────────────────────
Howdy,

Yesterday, I found myself in need of a routine to read and display the
directory tree in QB (actually PDS 7.1).  I scanned the echo and found
there was a discussion going on about how to do just that.  Seemed to
be 2 answers, get a LIB, and use SHELL "DIR > DIR.TXT".  Since I didn't
want to go searching for a lib, I tried the latter.  Basically, I modified
the WHEREIS program to look for directories instead of files.  It worked,
but it was also SLOWWWW!  On a 386sx/16 with a 15ms IDE drive and 176
directories, it took 97 seconds (compiled) to do the scan.  I KNEW there
had the be a better way!  I put some thought into it, and the following
code developed.  It will NOT work on a Mono system, due to the fact it
uses 2 video pages, but it works just fine with color.  The resulting
program will scan the same drive in 16.7 Seconds (compiled) or 19.5
seconds in the environment.  And it's ALL QB code!  Here 'tis:

------------------------------ CUT HERE -----------------------------------
DECLARE SUB GetDirs (Path$, Level%)
DECLARE SUB ShowTree ()
DEFINT A-Z
' Dimension Array to Hold Directories and Variable for Number of Dirs
DIM SHARED Path$(300), DCnt

' Set Active and Visual Pages to 1 and Clear Screen
SCREEN 0, , 1, 1: CLS

' Prompt User for Drive Letter and Prepare Screen
PRINT "Get Tree For Which Drive :";
DO: Drive$ = UCASE$(INKEY$): LOOP UNTIL LEN(Drive$): PRINT Drive$
PRINT "Scanning Drive " + Drive$ + " :"

' Set Frist Path to Root and Directory Count to 1
Path$(1) = Drive$ + ":": DCnt = 1

' Send Output to Page 0 (hide it)
SCREEN 0, , 0, 1

' Start Recursive Directory Scan
GetDirs Path$(1), 1

' Clear Screen and Set OutPut Back to Page 1 and Show Tree
CLS : SCREEN 0, , 1, 1
ShowTree

' Set All Pages to 0 and End
SCREEN 0, , 0, 0
END

SUB GetDirs (Path$, Level)
' Clear Screen, Display Sub Directories in Path$, Find out Last Line
CLS : FILES RTRIM$(Path$) + "\*.": LastLin = CSRLIN - 3

' Start Scanning Each Line of the Screen for Directory Entries
FOR Lin = 1 TO LastLin
  FOR Col = 0 TO 3   ' Start with Column Offset of 0
    D$ = ""          ' Clear Temp Character Variable
    DEF SEG = &HB800 ' Set Default Segment to Video Memory
    ' Read One Entry (17 Characters) From Video Memory
    FOR Char = 0 TO 34 STEP 2
      D$ = D$ + CHR$(PEEK(Lin * 160 + Col * 36 + Char))
    NEXT
    DEF SEG ' Set Default Segement Back to QB Data
    ' If Entry is a Sub Directory
    IF INSTR(D$, "<DIR>") AND INSTR(D$, ".") = 0 THEN
      ' Update Count on Visible Page
      DCnt = DCnt + 1: SCREEN 0, , 1, 1: LOCATE 2, 19
      PRINT LTRIM$(STR$(DCnt)): SCREEN 0, , 0, 1
      ' Add the Parent Path to the Name
      P$ = RTRIM$(Path$) + "\" + RTRIM$(LEFT$(D$, INSTR(D$, " ")))
      ' Store it to the Array
      Path$(DCnt) = P$
      ' Do a Recursive Search of That Sub for Subs
      GetDirs P$, Level + 1
      ' Find Last \ in Directory Name
      DO
        W = INSTR(W + 1, P$, "\"): IF W THEN P = W
      LOOP WHILE W
      ' Parse Out the Parent Directory
      P$ = LEFT$(P$, P - 1)
      ' Clear Screen, Re-Display Parent Directory, and Get Last Line
      CLS : FILES P$ + "\*.": LastLin = CSRLIN - 3
    END IF
  NEXT
NEXT
END SUB

SUB ShowTree
CLS : S = 1: Top = 1: IF DCnt < 22 THEN Max = DCnt - 1 ELSE Max = 22
Refresh:
OldN = 0: N = 0
FOR I = Top TO Top + Max
  P$ = Path$(I): N = 0: P = 0
  DO
    W = INSTR(W + 1, P$, "\"): IF W THEN P = W: N = N + 1
  LOOP WHILE W
  P2$ = Path$(I + 1): N2 = 0: P2 = 0
  DO
    W = INSTR(W + 1, P2$, "\"): IF W THEN P2 = W: N2 = N2 + 1
  LOOP WHILE W
  Nof$ = LEFT$(RIGHT$(P$, LEN(P$) - P) + SPACE$(20), 20)
  IF INSTR(Nof$, ":") THEN
    LOCATE I, S: PRINT LEFT$("\" + SPACE$(20), 20)
  ELSE
    T$ = "": FOR J = 1 TO N - 1: T$ = "│  " + T$: NEXT
    IF N2 < N THEN T$ = T$ + "└" ELSE T$ = T$ + "├"
    LOCATE I - Top + 1, S: PRINT T$ + "──";
    PRINT Nof$
  END IF
NEXT
DO: K$ = INKEY$: LOOP UNTIL LEN(K$)
IF LEN(K$) = 1 THEN K = ASC(K$) ELSE K = -ASC(RIGHT$(K$, 1))
SELECT CASE K
  CASE 27
    CLS : EXIT SUB
  CASE -80
    Top = Top + 1
  CASE -72
    Top = Top - 1
  CASE -73
    Top = Top - 19
  CASE -81
    Top = Top + 19
END SELECT
IF Top < 1 THEN Top = 1
IF Top + Max > DCnt THEN Top = DCnt - Max
GOTO Refresh

END SUB
------------------------------- CUT HERE --------------------------------

This Sub is to display the directory tree created by the previous sub.
It ain't much, but it works.

Any suggestions or comments about improving the speed would be greatly
appreciated!

Have fun with it!
Jerry Aldrich

--- Renegade v8-27 Beta
 * Origin: The Bumpkinland BBS - "Home of BLand Software" (1:296/3)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #20350
 Date:    12-06-92 22:23 (Public)
 From:    MARK REJHON
 To:      SHANE HEADER
 Subject: Alphabetizer FUNCTION
────────────────────────────────────────────────────────────────────────────────
 >         Does anyone have a FUNCTION that that will
 > alphabatize a complete
 > string array? I have tried unsucessfuly. I'm sure I could do
 > it, but I thought I would check with you guys to see if you had one
 > lying around.

The simplest sorting algorithm, for a 100 string array, non-case sensitive,
is listed below.  I assume that speed isn't important here.  <G>

DO
  Swapped% = 0
  FOR StringNum% = 1 TO 99
    IF UCASE$(Array$(StringNum%)) > UCASE$(Array$(StringNum% + 1)) THEN
      SWAP Array$(StringNum%), Array$(StringNum% + 1)
      Swapped% = -1
    ENDIF
  NEXT StringNum%
LOOP WHILE Swapped%


Mark Rejhon

--- FMail 0.92
 * Origin: +++ VIddIBBS +++ [phone]! (1:163/255)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #20558
 Date:    12-03-92 23:13 (Public)
 From:    ERIC B. FORD
 To:      MICHEL BERTLER
 Subject: Prime numbers gen.
────────────────────────────────────────────────────────────────────────────────
 > Your program is quite fast! However, could you make it
 > ask for a user
 > input (upper limit) and redirect its output into a
 > readable Ascii file rather than on the screen?

Well, here's a version to have an upper limit.  (For above 32767 change to
LONGs)  To redirect it to an ASCII file you can just compile and then do
something like:

PRIME >Primes.txt

' Load QB with the "/l" option
DIM prime(32767) AS INTEGER: CLS
PRINT "                        Prime Number Generater"
PRINT "                             Eric Ford"
PRINT
PRINT "What number would you like to end checking at?"
INPUT Last%
PRINT : PRINT

INPUT "Filename (Leave blank for screen)"; File$

PRINT "The numbers below are prime.        Now testing..."

tim1 = TIMER: half% = Last% / 2 + 1

    FOR i% = 3 TO half% STEP 2
        j% = 2
        WHILE j% * i% <= Last%
            prime(j% * i%) = 1
            j% = j% + 1
            WEND
    NEXT i%

    FOR j% = 4 TO Last% STEP 2
        prime(j%) = 1
    NEXT j%

FOR First% = 1 TO 3
    prime(First%) = 0
NEXT First%

tim2 = TIMER


IF len(ltrim$(rtrim$(File$))) = 0 then
    FOR i% = 2 TO Last%
        IF prime(i%) = 0 THEN primes = primes + 1: PRINT i%
    NEXT i%
else
    open file$ for output as #1
    for i% = 2 to Last%
        if prime(i%) = 0 then
            primes = primes + 1
            print #1, i%
        end if
    next i%
    close
end if

tim = tim2 - tim1
PRINT "     ---   Done   ---      "; primes;
PRINT " primes computed in"; tim; "seconds"


A good deal of this is from the message editor and not QB, so beware of minor
mistooks.

---
 * Origin: Eric Ford (1:3632/1.6)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #20619
 Date:    12-06-92 20:51 (Public)
 From:    BRENT ASHLEY
 To:      JOHN GALLAS
 Subject: QB SIMULATNEOUS INPUT
────────────────────────────────────────────────────────────────────────────────
Here it is again - without any embellishment.  - Brent -

'BASIC test code:
DECLARE FUNCTION KeyPressed%(ScanCode%)
CALL InstKeyPress ' install resident code
CLS
DO
  LOCATE 1,1
  FOR i% = 2 TO 9 ' scancode of 1 to 8
    IF KeyPressed(i%) THEN PRINT CHR$(47+i%); ELSE PRINT " ";
  NEXT
  PRINT
LOOP UNTIL INKEY$=CHR$(27) ' escape to quit
CALL UnHookKeyPress ' unhook resident code - IMPORTANT!!!
END

; KeyPress.ASM by Brent Ashley
;   checks the "pressed" status of any key
.model medium, basic
.code
Old09        Label Dword       ;Label for to old Int 09h handler
Old09Offset  dw ?              ;Offset part
Old09Segment dw ?              ;Segment part
Hooked       db 0              ;Our installed flag
KeyMap       db 80 dup(0)      ;map of kybd, one byte per scancode
InstKeyPress proc uses ds ax dx ; From BASIC: CALL InstKeyPress
                               ; REMEMBER to call UnhookKeyPress!
        cmp cs:Hooked,0        ;Are we already hooked?
        jnz InstallExit        ;If so, exit
        mov ax,3509h           ;Get current vector for int 09h
        int 21h
        mov cs:Old09Segment,es ;Remember it for later
        mov cs:Old09Offset,bx
        mov ax,2509h
        push ds
        push cs
        pop ds                 ;Point int 09h handler to our code
        mov dx, offset OurInt09
        int 21h
        pop ds
        mov cs:Hooked,-1       ;Set our installed flag
InstallExit:
        ret
OurInt09:                      ;Our Int 09h handler
        push ax
        push bx
        push dx
        push si
        in al, 60h
        test al, 080h          ;is "released" bit set?
        jnz Released           ;yup - go to it
        mov dl, 0FFh           ;nope - set key pressed flag
        jmp PutFlag
Released:
        and al, 07Fh           ;yes - clear bit for index
        mov dl, 0              ;and set flag for release
PutFlag:
        xor ah, ah
        mov si, ax             ;assign index
        mov cs:KeyMap[si], dl  ;put flag in place
        pop si
        pop dx
        pop bx
        pop ax
Continue:
        jmp dword ptr cs:[Old09];Transfer ctrl to orig Int 09h
InstKeyPress endp
KeyPressed proc uses bx si, ScanCode:WORD
        ; from BASIC: TrueOrFalse% = KeyPressed(ScanCode%)
        mov bx, ScanCode       ;get scan code addr
        mov si, [bx]           ;load value as index
        mov al, cs:KeyMap[si]  ;put flag in al
        cbw                    ;convert to word for integer value
        ret
KeyPressed endp
UnhookKeyPress proc            ; from BASIC: CALL UnHookKeyPress
        cmp cs:Hooked,0        ; are we installed?
        jz UnHooked            ; nope - exit
        push ax
        push ds
        mov ax,2509h           ;Unhook ourself
        mov ds,Old09Segment
        mov dx,Old09Offset
        int 21h                ;Point Int 09h back to orig hndlr
        pop ds
        pop ax
        mov cs:Hooked,0        ;Set installed flag back to zero
UnHooked:
        ret
UnhookKeyPress endp
END
--- FidoPCB v1.3 [ff053/x]
 * Origin: Canada Remote Systems, Mississauga, Ontario  (1:229/15)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #20725
 Date:    12-07-92 21:06 (Public)
 From:    EARL MONTGOMERY
 To:      ALL
 Subject: Animation (Page Flipping)
────────────────────────────────────────────────────────────────────────────────
I had asked in previous posts how I could avoid the PCOPY 7,0.
Well I finally figure it out. I had forgotten about the SWAP
command. For those that are interested here is the code again:
DEFINT A-Z: SCREEN 7: CLS : x = 60: pg = -1: v = 118: h = 30: up = 23
write2page% = 1: viewpage% = 0
Q$ = "E2U2R1U4H2R3U1D1R2U1D1R3G2D4R1D2F2L10"
n$ = "E2U1E2U2G2L1H1U1E4R3F2D4G1D2F2L10"
start:
FOR c = 0 TO 7
x = x + 1: h = h + 1: pg = pg + 1: up = up - 1
IF up < 5 THEN up = 23
SCREEN , , write2page%, viewpage%
CLS
LOCATE 2, 2: COLOR 3: PRINT "Demo Of Animation Using Page Flipping"
LOCATE up, 10: COLOR 1: PRINT "Chess Pieces In The Sky"
DRAW "BM=" + VARPTR$(x) + ",=" + VARPTR$(v)
DRAW "s8;C8;X" + VARPTR$(Q$): PAINT (x + 4, v - 2), 4, 8
DRAW "BM=" + VARPTR$(h) + ",=" + VARPTR$(v)
DRAW "C8;X" + VARPTR$(n$): PAINT (h + 4, v - 2), 15, 8
FOR z = 0 TO 50
PSET (RND * 320, RND * 200), RND * 15
SWAP write2page%, viewpage%
IF x > 300 THEN GOTO holdscrn
NEXT: NEXT
GOTO start
holdscrn:
GOTO holdscrn
' E N D
Earl

--- Maximus 2.01wb
 * Origin: Rabbit and Snake's BBS - Richardson, Texas (1:124/6108)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #21116
 Date:    12-07-92 07:49 (Public)
 From:    ZACK JONES
 To:      TOM CARROLL
 Subject: FIDO MESSAGES
────────────────────────────────────────────────────────────────────────────────
Hello Tom!

04 Dec 92, Tom Carroll writes to All:

 TC> Does anyone know how to get the Destination Zone and Origin Zone numbers
 TC> from a fido style .MSG?

Here's something I picked up some time ago - hopefully this will help.
Credit, of course, goes to Marshall Emm.


'By: Marshall Emm
REM Define the header of a Fido message
TYPE msghdr
 FromUserName AS STRING * 36
   ToUserName AS STRING * 36
      Subject AS STRING * 72
     DateTime AS STRING * 20
    TimesRead AS INTEGER
     DestNode AS INTEGER
     OrigNode AS INTEGER
         Cost AS INTEGER
      OrigNet AS INTEGER
      DestNet AS INTEGER
         Fill AS STRING * 8
      ReplyTo AS INTEGER
    Attribute AS INTEGER
    NextReply AS INTEGER
END TYPE

DIM Header AS msghdr
f$ = "d:2.msg"

OPEN f$ FOR BINARY AS 1
  GET 1, 1, Header
  size = LOF(1) - LEN(Header) + 1:  Message$ = STRING$(size, 0)
  GET 1, LEN(Header) + 1, Message$ 'text of message, i.e.
  '                                everything after the header
CLOSE

PRINT "Message file: "; f$
PRINT
PRINT "FromUserName: "; Header.FromUserName
PRINT "  ToUserName: "; Header.ToUserName
PRINT "     Subject: "; Header.Subject
PRINT
PRINT "     OrigNet: "; Header.OrigNet
PRINT "    OrigNode: "; Header.OrigNode
PRINT "     DestNet: "; Header.DestNet
PRINT "    DestNode: "; Header.DestNode
PRINT
PRINT "    DateTime: "; Header.DateTime
PRINT "   TimesRead: "; Header.TimesRead
PRINT "        Cost: "; Header.Cost
PRINT
PRINT "     ReplyTo: "; Header.ReplyTo
PRINT "   Attribute: "; Header.Attribute
PRINT "   NextReply: "; Header.NextReply
PRINT
PRINT Message$
'now the fun starts if you want to format the text of Message$, which
'is a single "line."

Zack

--- GoldED 2.40
 * Origin: Zack's Shack San Antonio, TX  [phone] (1:387/641)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #21943
 Date:    12-07-92 22:52 (Public)
 From:    JOE NEGRON
 To:      SHANE HEADER
 Subject: Alphabetizer FUNCTION
────────────────────────────────────────────────────────────────────────────────
SH> Does anyone have a FUNCTION that that will alphabatize a complete
  > string array? I have tried unsucessfuly. I'm sure I could do it, but I
  > thought I would check with you guys to see if you had one lying around.

What you need is a sort routine.  There are a number of different
sorting methods; here is a relatively simple one, based on the Bubble
Sort, called a "Comb" sort:

============================== Begin code ==============================
DEFINT A-Z

DECLARE SUB CombSort (Array$())

'***********************************************************************
'* SUB CombSort
'*
'* PURPOSE
'*    Sorts an array using the Comb sort algorithm.
'*
'* CREDIT(S)
'*    This routine was taken from the article "A Fast, Easy Sort", by
'*    Stephen Lacey and Richard Box, from the "Hands On" column of the
'*    April 1991 issue of Byte.
'***********************************************************************
SUB CombSort (Array$()) STATIC
   FirstEl% = LBOUND(Array$)
   LastEl% = UBOUND(Array$)
   Gap% = LastEl%

   DO
      IF Gap% * 8 / 11 > 1 THEN
         Gap% = Gap% * 8 / 11
      ELSE
         Gap% = 1
      END IF

      Switch% = 0

      FOR I% = FirstEl% TO LastEl% - Gap%
         J% = I% + Gap%
         IF Array$(I%) > Array$(J%) THEN
            SWAP Array$(I%), Array$(J%)
            Switch% = Switch% + 1
         END IF
      NEXT I%
   LOOP UNTIL Switch% = 0 AND Gap% = 1
END SUB
=============================== End code ===============================

Simply pass your array to this SUB as follows:

   CombSort Array$()

or

   CALL CombSort(Array$())

As I said, there are a number of different sorting algorithms.  I use
this one the majority of the time since it is small, simple, and fairly
fast.

Just for comparison's sake, here is a Shell sort:

============================== Begin code ==============================
DEFINT A-Z

DECLARE SUB ShellSort (Array$())

'***********************************************************************
'* SUB ShellSort
'*
'* PURPOSE
'*    Sorts an array using the shell sort algorithm.
'***********************************************************************
SUB ShellSort (Array$()) STATIC
   FirstEl% = LBOUND(Array$)
   LastEl% = UBOUND(Array$)
   Span% = LastEl% \ 2

   DO WHILE Span% > 0
      Boundary% = LastEl% - Span%

      DO
         Flag% = 0

         FOR I% = FirstEl% TO Boundary%
            IF Array$(I%) > Array$(I% + Span%) THEN
               SWAP Array$(I%), Array$(I% + Span%)
               Flag% = I%
            END IF
         NEXT I%

         Boundary% = Flag% - Span%
      LOOP WHILE Flag%

      Span% = Span% \ 2
   LOOP
END SUB
=============================== End code ===============================

Both of these routines are fairly fast, and require a minimal amout of
memory.

BTW, these routines are implemented as SUBs rather than FUNCTIONs,
because they do not need to return a value to the caller.

                                --Joe in Bay Ridge, Brooklyn, NY--
                                      Mon  12-07-1992, 22:38

 * SLMR 2.1a * Windows: Brought to you by the makers of Edlin!

--- Maximus 2.01wb
 * Origin: * BlueDog BBS * [phone] * NYC FileBone Hub (1:278/709)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #22064
 Date:    12-07-92 23:29 (Public)
 From:    ERIC B. FORD
 To:      JEFFERY FOY
 Subject: *.MSG
────────────────────────────────────────────────────────────────────────────────
Ah, looking at this I wonder:

'
' *** MAILFIND V1.00 Copyright 1992 Eric Ford ***
'
'ON ERROR GOTO errmsg:

 ' Open the file

 TYPE headertype
      fromname  AS STRING * 36
      toname    AS STRING * 36
      subject   AS STRING * 72
      datetime  AS STRING * 20
      timesread AS INTEGER
      destnode  AS INTEGER
      orignode  AS INTEGER
      cost      AS INTEGER
      orignet   AS INTEGER
      destnet   AS INTEGER
      fill      AS STRING * 8           '  WHAT???
      replyto   AS INTEGER
      attribute AS INTEGER
      nextreply AS INTEGER
 END TYPE

What's in there?  Anything important?  Does Front Door need that dumb stuff
or is it 'reserved'?  I am thinking of adding a automatic routing system to
VIPMAIL (BTW- Any suggestions?)  and need some place to put it, and would
prefer not to have to invade the message body.  Can I stuff it there?  Any
other ideas?

---
 * Origin: Eric Ford (1:3632/1.6)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #22629
 Date:    12-08-92 13:13 (Public)
 From:    ROB MCKEE
 To:      ALL
 Subject: Errorlevel
────────────────────────────────────────────────────────────────────────────────
Hi All,
      I found out where MS-Dos V.5 Command.com keeps the  ErrorLevel Info
(plus &h2b3 from the beginning of Command.com as Listed by Mem /d)  Does
anyone know

C:\>MEM/D

  Address     Name          Size       Type
  -------     --------     ------     ------
  000000                   000400     Interrupt Vector
  000400                   000100     ROM Communication Area
  000500                   000200     DOS Communication Area

  000700      IO           000A60     System Data
                  CON                   System Device Driver
  _____________________/\  ____________________________
                         \/
                  COM4                  System Device Driver

  001160      MSDOS        0013D0     System Data

  002530      IO           002C70     System Data
  _____________________/\  ____________________________
                         \/
  0051B0      MSDOS        000040     System Program

  005200      COMMAND      000940     Program
  005B50      EZPOINT      000040     Data
  005BA0      COMMAND      000400     Environment

 The byte on my computer as configured is 0054B3.  But what I want to know
how to do is access the List of List from within QBas.  I wrote an ASM
program thats hardcoded to read the Byte at &h54b3.  I would like to be able
to find where COMMAND.COM start's in any computer and then read the
ERRORLEVEL.

 n ErrLvl.com
 RCX
 4b
 a
   MOV AX,054B                   ; Point to Segment
   PUSH    DS                    ; Save Data Seg
   MOV DS,AX                     ; Load new Data Segment
   MOV AL,[0003]                 ; Get Errorlevel
   POP DS                        ; Restore Data Segment
   JMP 0113                      ; Jmp around Data
   DB 00 00 00 0D 0A 24 00       ; Working Data
   MOV [0112],AL                 ; Save Errorlevel
   CMP AL,00                     ; Is it 0 don't need to Divide then
   JZ  012F                      ; If 0 skip Divide
   XOR AH,AH                     ; 0 out Remainder
   MOV BL,0A                     ; Set Divisor
   DIV BL                        ; Divide
   MOV [010E],AH                 ; Save the 1's digit
   XOR AH,AH                     ; 0 out Remainder
   DIV BL                        ; Divide
   MOV [010D],AH                 ; Save the 10's digit
   MOV [010C],AL                 ; Save the 100's digit
   MOV DX,010C                   ; Set start of string
   MOV AH,09                     ; Load for Output String Func
   ADD BYTE PTR [010C],30        ; Add 30h to make it Ascii #
   ADD BYTE PTR [010D],30        ; Add 30h to make it Ascii #
   ADD BYTE PTR [010E],30        ; Add 30h to make it Ascii #
   INT 21                        ; Output the String
   MOV AL,[0112]                 ; Get the ERRORLEVEL again
   MOV AH,4C                     ; Setup for Exit with ERRORLEVEL
   INT 21                        ; ByeBye...

   w
   q
 ------------------------------ 8< ---------------------------
 AS you can see, it Exit's with the same Errorlevel that it had coming into
it.  I have a listing of the Dos 3.x Master List but I don't know if it's the
same as Dos 5.  If I can intercept the ErrorLevel inside Qbas then I can
replace alot of 'IF ERRORLEVEL statements in my Bat Files and do more things
in my Bat files.

                               TTYL -Rob

--- EZPoint V2.1
 * Origin: Flyer Proof Computer Services V# 510-237-8091 (1:125/1212.13)

                               TTYL -Rob


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #23279
 Date:    12-08-92 07:56 (Public)
 From:    DAVID COLSTON
 To:      ALL
 Subject: Sorts
────────────────────────────────────────────────────────────────────────────────
I have caught several post on sorts. In particular a need to sort a
directory. Here is a sample program for this in 7.1.
DECLARE SUB QuickSort (A$(), NumberofRecords!)
DIM A$(1000)
Count = 1
Filespect$ = "*.*"
A$(Count) = DIR$(Filespect$)
IF LEN(A$(1)) > 0 THEN
     DO
          A$ = DIR$
          IF LEN(A$) > 0 THEN
               Count = Count + 1
               A$(Count) = A$
          END IF
     LOOP UNTIL LEN(A$) = 0
ELSE
  Count = 0
END IF
IF Count > 0 THEN
    QuickSort A$(), Count
    OPEN "O", 2, "Files.Dir"
     FOR I = 1 TO Count
          PRINT #2, A$(I)
     NEXT
     CLOSE
END IF

SUB QuickSort (A$(), NumberofRecords) STATIC
False = 0
     Offset = NumberofRecords \ 2
     ' Loop until offset gets to zero:
     DO WHILE Offset > 0
          Limit = NumberofRecords - Offset
          DO

      ' Assume no switches at this offset:
      Switch = False

      ' Compare elements and switch ones out of order:
      FOR I = 1 TO Limit
           IF A$(I) > A$(I + Offset) THEN
                SWAP A$(I), A$(I + Offset)
                Switch = I
           END IF
      NEXT I

      ' Sort on next pass only to where
      ' last switch was made:
      Limit = Switch
          LOOP WHILE Switch

          ' No switches at last offset, try one half as big:
          Offset = Offset \ 2
     LOOP

END SUB


'I hope this helps some of you.

 * OLX 2.1 TD * Press any key to continue or any other key to quit


--- WM v2.04/92-0178
 * Origin: Paradox of Arkansas *Wildcat 3.0* 501-646-7158 (1:19/121)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #24372
 Date:    12-10-92 02:52 (Public)
 From:    JOHN SNEERINGER
 To:      SHANE HEADER
 Subject: Alphabetizer FUNCTION
────────────────────────────────────────────────────────────────────────────────
* Originally addressed to All, Shane Header said:
SH->        Does anyone have a FUNCTION that that will
SH->alphabatize a complete
SH->string array? I have tried unsucessfuly. I'm sure I could do
SH->it, but I
SH->thought I would check with you guys to see if you had one
SH->lying around.

DEFINT A-Z

' ==============================================================
' The Fastest QuickBasic Sort Routine Alive. 516% faster than
' any living bubble array. THIS ONE DOES STRINGS, NOT NUMERICS.
' ==============================================================

DECLARE FUNCTION RandInt% (Lower, Upper)
DECLARE SUB QuickSort (Low, High)
DIM SHARED SortArray$(11)

CLS

SortArray$(1) = "6"
SortArray$(2) = "3"
SortArray$(3) = "5"
SortArray$(4) = "6"
SortArray$(5) = "8"
SortArray$(6) = "9"
SortArray$(7) = "5"
SortArray$(8) = "4"
SortArray$(9) = "3"
SortArray$(10) = "2"
SortArray$(11) = "1"
Low = 1
High = 11


CALL QuickSort(Low, High)

FOR a = Low TO High
PRINT SortArray$(a)
NEXT

SUB QuickSort (Low, High)

   IF Low < High THEN

      IF High - Low = 1 THEN
         IF SortArray$(Low) > SortArray$(High) THEN
            SWAP SortArray$(Low), SortArray$(High)
         END IF
      ELSE

         RandIndex = RandInt%(Low, High)
         SWAP SortArray$(High), SortArray$(RandIndex)
         Partition$ = SortArray$(High)
         DO

            I = Low: J = High
            DO WHILE (I < J) AND (SortArray$(I) <= Partition$)
               I = I + 1
--- D'Bridge 1.30/071082
 * Origin: RadioLink! Columbus, OH [phone] HST/DS (1:226/140)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #24373
 Date:    12-10-92 02:54 (Public)
 From:    JOHN SNEERINGER
 To:      ALL
 Subject: Rest of Q-Sort
────────────────────────────────────────────────────────────────────────────────
            LOOP
            DO WHILE (J > I) AND (SortArray$(J) >= Partition$)
               J = J - 1
            LOOP

            IF I < J THEN
               SWAP SortArray$(I), SortArray$(J)
            END IF
         LOOP WHILE I < J

         SWAP SortArray$(I), SortArray$(High)

         IF (I - Low) < (High - I) THEN
            QuickSort Low, I - 1
            QuickSort I + 1, High
         ELSE
            QuickSort I + 1, High
            QuickSort Low, I - 1
         END IF
      END IF
   END IF
END SUB

FUNCTION RandInt% (Lower, Upper) STATIC

' =======================================================================
'   Returns a random integer greater than or equal to the Lower parameter
'   and less than or equal to the Upper parameter.
' =======================================================================

   RandInt% = INT(RND * (Upper - Lower + 1)) + Lower
END FUNCTION

---
 * Origin: RadioLink! Columbus, OH [phone] QuickBasic! HST/DS
(1:226/140)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #3326
 Date:    12-08-92 15:36 (Public)
 From:    VICTOR YIU
 To:      MICHEL BERTLER
 Subject: Prime numbers gen.
────────────────────────────────────────────────────────────────────────────────
 -=> Quoting Eric B. Ford to Michel Bertler <=-

To redirect:
 EBF> PRIME >Primes.txt

________Clip here_______

' the slightly modified version of
' Eric Ford's prime # generator

DEFINT A-Z: CLS

INPUT "Highest #"; Last
DIM Prime(Last + 1) AS INTEGER

H = Last \ 2
T! = TIMER

FOR I = 3 TO H STEP 2
    J = 2
    WHILE J * I <= Last
        Prime(J * I) = 1
        J = J + 1
    WEND
NEXT I

FOR J = 4 TO Last STEP 4
    Prime(J) = 1
NEXT J

T! = TIMER - T!

PRINT "2  3";

FOR I = 3 TO Last STEP 2
    IF Prime(I) = 0 THEN PRINT I;
NEXT I

PRINT
PRINT "Computed in"; T!; "seconds"

_______
This program is much neater (and slightly faster I think) than the
on-the-fly program he made...

... Restroom meter:  [......../]  Aaarhgh.  I've got to go!!!
--- Blue Wave/RA v2.10 [NR]
 * Origin: Hard Disc Cafe / Houston Texas / [phone] / (1:106/30.0)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #3755
 Date:    12-11-92 06:33 (Public)
 From:    STEVE GARTRELL
 To:      GEOFFREY LIU
 Subject: Rotate GET/PUT arrays
────────────────────────────────────────────────────────────────────────────────
'For big arrays, this screams for conversion to assembly.
'But, using this, it's just a translation job.
'Remember, this is a pixel by pixel rotation, so at
'angles other than 0 or 180, lettering is reversed.  (You'd
'need to approach it in blocks the size of a standard
'character in whichever screen mode you were in, to do
'writing.  I wasn't going to do it all!!!)
DEFINT A-Z
DECLARE SUB RotateArray (SourceArray%(), TargetArray%(), Angle%)
'Must have the appropriate QB.QLB/QBX.QLB/VBDOS.QLB loaded
' if in the environment-link with appropriate library....
DECLARE SUB ABSOLUTE (Var%, BYVAL HowFar%, address AS INTEGER)
CONST C$ = "Created 12/01/92 by Steve Gartrell"
CONST NumBytes = 21
'$STATIC
DIM SHARED RORproc%(1 TO (NumBytes / 2))
'$DYNAMIC
DIM SHARED BitsPP%, Planes%, MaskBits%
DIM TheScreens%(1 TO 9)
offset% = VARPTR(RORproc%(1))
FOR byte% = 0 TO NumBytes - 1
  READ opcode%
  POKE (offset% + byte%), opcode%
NEXT byte%
TheScreens%(1) = 1
TheScreens%(2) = 2
TheScreens%(3) = 7
TheScreens%(4) = 8
TheScreens%(5) = 9
TheScreens%(6) = 11
TheScreens%(7) = 12
TheScreens%(8) = 13
KEY OFF
ScrCnt% = 8
DO
  SCREEN TheScreens%(ScrCnt%)
  MaskBits% = 128
  SELECT CASE TheScreens%(ScrCnt%)
    CASE 1   'Screen 1
    MaskBits% = 192
    BitsPP% = 2: Planes% = 1
    ColorMod% = 3
    CASE 2   'Screen 2
    BitsPP% = 1: Planes% = 1
    ColorMod% = 2
    CASE 7   'Screen 7
    BitsPP% = 1: Planes% = 4
    ColorMod% = 16
    CASE 8   'Screen 8
    BitsPP% = 1: Planes% = 4
    ColorMod% = 16
    CASE 9  'Screen 9
    BitsPP% = 1: Planes% = 4
    ColorMod% = 16
    CASE 11  'Screen 11
    BitsPP% = 1: Planes% = 1
    ColorMod% = 2
    CASE 12  'Screen 12
    BitsPP% = 1: Planes% = 4
    ColorMod% = 16
    CASE 13  'Screen 13
    MaskBits% = 255
    BitsPP% = 8: Planes% = 1
    ColorMod% = 256
  END SELECT
  StartX% = 119: StartY% = 55: EndX% = 199: EndY% = 135
  ArrayBytes& = 4 + INT(((EndX% - StartX% + 1)_
 * (BitsPP%) + 7) / 8) * Planes% * ((EndY% - StartY%) + 1)
  REDIM SourceArray%(0 TO ArrayBytes& \ 2)
  REDIM BlankArray%(0 TO ArrayBytes& \ 2)
  REDIM TargetArray%(0 TO 20)
  GET (StartX%, StartY%)-(EndX%, EndY%), BlankArray%(0)
  FOR TheLine% = 1 TO 24
    LOCATE TheLine%, 1
    FOR cnt% = 33 TO 72
      SELECT CASE TheScreens%(ScrCnt%)
        CASE 1, 2, 11
        CASE ELSE
          COLOR cnt% MOD ColorMod%
      END SELECT
      PRINT CHR$(cnt%);
    NEXT
    IF TheLine% <> 24 THEN PRINT
  NEXT
  GET (StartX%, StartY%)-(EndX%, EndY%), SourceArray%(0)
  DO
    DO: t$ = UCASE$(INKEY$): LOOP UNTIL LEN(t$)
    SELECT CASE t$
      CASE "Q"  'QUIT!!!!!
        SCREEN 0: WIDTH 80: COLOR 7, 0: END
      CASE "N"  'CHANGE SCREEN MODE!!!
        ScrCnt% = ScrCnt% + 1
        IF ScrCnt% = 9 THEN ScrCnt% = 1
        EXIT DO
      CASE ELSE  'ROTATE!!!!
        Angle% = (Angle% + 90) MOD 360
        RotateArray SourceArray%(), TargetArray%(), Angle%
        WAIT &H3DA, 8, 8
        WAIT &H3DA, 8
        PUT (StartX%, StartY%), BlankArray%(0), PSET
        PUT (StartX%, StartY%), TargetArray%(0), PSET
        ERASE TargetArray%
    END SELECT
  LOOP
LOOP
RotRight:
DATA &H55              : 'push   bp
DATA &H8B,&HEC         : 'mov    bp, sp
DATA &H51              : 'push   cx
DATA &H8B,&H4E,&H06    : 'mov    cx, [bp + 6]
DATA &H8B,&H5E,&H08    : 'mov    bx, [bp + 8]
DATA &H8B,&H07         : 'mov    ax, [bx]
DATA &HD2,&HC8         : 'ror    al, cl
DATA &H89,&H07         : 'mov    [bx], ax
DATA &H59              : 'pop    cx
DATA &H5D              : 'pop    bp
DATA &HCA,&H04,&H00    : 'retf   4
REM $STATIC
DEFSNG A-Z
SUB RotateArray (SourceArray%(), TargetArray%(), Angle%)
DIM SourcePix%(1 TO 4)
DIM SourceBitsPP%, SourceBytesPerRow&, SourceRowOffset&
DIM SourceX%, SourceY%, BytePosCopy&, SourceBytePos&
DIM SourceRightMove%, SourceBitMask%, SourceToTargetDiff%
DIM TargetBitsPP%, TargetBytesPerRow&, TargetRowOffset&
DIM TargetRightMove%, TargetBytePos&, TargetX%, TargetY%
DIM WhichBits%, NumCols%, NumRows%
SELECT CASE BitsPP%
  CASE 1
    WhichBits% = 7
  CASE 2
    WhichBits% = 3
  CASE 8
    WhichBits% = 0
END SELECT
SourceBitsPP% = SourceArray%(0)
NumCols% = SourceBitsPP% \ BitsPP%
NumRows% = SourceArray%(1)
IF Angle% MOD 180 THEN
  'Make it square if it's not!!!
  SELECT CASE NumRows% - NumCols%
    CASE IS < 0
      NumCols% = NumRows%
    CASE IS > 0
      NumRows% = NumCols%
  END SELECT
END IF
TargetBitsPP% = NumCols% * BitsPP%
IF TargetBitsPP% AND 7 THEN
  TargetBytesPerRow& = (TargetBitsPP% \ 8 + 1) * Planes%
ELSE
  TargetBytesPerRow& = (TargetBitsPP% \ 8) * Planes%
END IF
REDIM TargetArray%(0 TO ((TargetBytesPerRow& * NumRows%) \ 2) + 2)
TargetArray%(0) = TargetBitsPP%
TargetArray%(1) = NumRows%
TargetBytesPerPlane% = TargetBytesPerRow& \ Planes%
IF SourceBitsPP% MOD 8 THEN
  SourceBytesPerPlane% = (SourceBitsPP% \ 8 + 1)
ELSE
  SourceBytesPerPlane% = (SourceBitsPP% \ 8)
END IF
SourceBytesPerRow& = SourceBytesPerPlane% * Planes%
SourceRowOffset& = 4
SourceBytePos& = SourceRowOffset&
SourceRightMove% = 0
SourceBitMask% = MaskBits%
FOR SourceY% = 0 TO NumRows% - 1
  FOR SourceX% = 0 TO NumCols% - 1
    SELECT CASE Angle%
      CASE 90
        TargetX% = NumRows% - SourceY% - 1
        TargetY% = NumCols% - SourceX% - 1
      CASE 180
        TargetX% = NumCols% - SourceX% - 1
        TargetY% = NumRows% - SourceY% - 1
      CASE 270
        TargetX% = SourceY%
        TargetY% = SourceX%
      CASE ELSE
        TargetX% = SourceX%
        TargetY% = SourceY%
    END SELECT
    TargetRowOffset& = (TargetY% * TargetBytesPerRow&) + 4
    TargetBytePos& = TargetRowOffset& + ((TargetX% * BitsPP%) \ 8)
    TargetRightMove% = TargetX% AND WhichBits%
    IF BitsPP% = 2 THEN
      TargetRightMove% = TargetRightMove% + TargetRightMove%
    END IF
    SourceToTargetDiff% = (TargetRightMove% - SourceRightMove% + 8) AND 7
    BytePosCopy& = SourceBytePos&
    DEF SEG = VARSEG(SourceArray%(0))
    FOR PlaneNum% = 1 TO Planes%
      SourcePix%(PlaneNum%) = (PEEK(BytePosCopy&) AND SourceBitMask%)
      BytePosCopy& = BytePosCopy& + SourceBytesPerPlane%
    NEXT
    IF SourceToTargetDiff% THEN
      DEF SEG
      RotRight% = VARPTR(RORproc%(1))
      FOR PlaneNum% = 1 TO Planes%
        CALL ABSOLUTE(SourcePix%(PlaneNum%), BYVAL_
 SourceToTargetDiff%, RotRight%)
      NEXT
    END IF
    DEF SEG = VARSEG(TargetArray%(0))
    FOR PlaneNum% = 1 TO Planes%
      POKE TargetBytePos&, PEEK(TargetBytePos&) OR SourcePix%(PlaneNum%)
      TargetBytePos& = TargetBytePos& + TargetBytesPerPlane%
    NEXT
    DEF SEG
    SourceRightMove% = (SourceRightMove% + BitsPP%) AND 7
    IF SourceBitMask% AND 1 THEN
      SourceBitMask% = MaskBits%
      SourceBytePos& = SourceBytePos& + 1
    ELSE
      RotRight% = VARPTR(RORproc%(1))
      CALL ABSOLUTE(SourceBitMask%, BYVAL BitsPP%, RotRight%)
    END IF
  NEXT
  SourceRowOffset& = SourceRowOffset& + SourceBytesPerRow&
  SourceBytePos& = SourceRowOffset&
  SourceBitMask% = MaskBits%
  SourceRightMove% = 0
NEXT
END SUB

--- D'Bridge 1.30/071082
 * Origin: RadioLink! Columbus, OH [phone] HST/DS (1:226/140)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #5888
 Date:    12-11-92 13:32 (Public)
 From:    SCOTT MAYFIELD
 To:      TERRY ROSSI
 Subject: WORD WRAP CODE
────────────────────────────────────────────────────────────────────────────────
TR-=>A am becoming brain dead in my old age and cannot fiqure out how to
handle
TR-=>problem.  I need to break a line that i read in from file A into two line
TR-=>file B, I am able to do that but I cannot fiqure out a good way to do a
wo
TR-=>wrap.  Right now the software breaks the line at column 79 regardless of
w
TR-=>the word ends.  I would like to have it break at the closest space to
colu
TR-=>so the the next line begins with a complete word.   Anybody have any
ideas

I'll leave you to figger out most of the code ;), but here's your
algorithm...

Read in your line from file A
strip off any trailing blanks (RTRIM$())
starting at the end, locate the space character closest to the end.
  FOR I% = LEN(TextFromA$) TO 1 STEP -1
    IF MID$(TextFromA$, I%, 1) = " " THEN
      SpaceLocation% = I%
      EXIT FOR
    END IF
  NEXT I%
  IF SpaceLoc% = 0 THEN SpaceLoc% = 79 ' No space in string, use whole
                                       ' thing...
Assign string 1 to be the left SpaceLoc%-1 characters of TextFromA$
Assign String 2 to be thr right Len(TextFromA$)-SpaceLoc% characters of
  TextFromA$
write out string 1 to file B
loop back, reading next line from A and adding string 2 to the beginning
  of it.

Scott @ 1:234/2


 * SLMR 2.1 * On a clear disk you can seek forever

--- TMail v1.31
 * Origin: Toledo's TBBS, 4+ gigs, 50,000 files 313-854-6001 (1:234/2)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #6624
 Date:    12-13-92 02:03 (Public)
 From:    JOE NEGRON
 To:      BOB OEHRLE
 Subject: Date$   ???
────────────────────────────────────────────────────────────────────────────────
BO> While in Dos if I call for the date I get Wed-12-12-92. If I print
  > date$ in qb4.5 I get 12-12-92.  Is there away that I can get the days
  > to print ?? It seems that if I use Mid$ function I can't extract Wed .
  > I'm trying to write a calendar routine that will alert me at start up
  > every wednesday to preform a particular job.
  > Bob in NJ

BASIC's DATE$ function does not return the day of the week.  The
following does:
============================== Begin code ==============================
DEFINT A-Z

'$INCLUDE: 'qbx.bi'

DECLARE FUNCTION DOW$ ()

PRINT DOW$

SYSTEM

'***********************************************************************
'* FUNCTION DOW$
'*
'* PURPOSE
'*    Uses DOS ISR 21H, Function 2AH (Get Date) to return the current
'*    day of the week.
'*
'* EXTERNAL ROUTINE(S)
'*    QBX.LIB
'*    -------
'*    SUB Interrupt (IntNum%, IRegs AS RegType, ORegs AS RegType)
'***********************************************************************
FUNCTION DOW$ STATIC
   DIM IRegs AS RegType, ORegs AS RegType

   IRegs.ax = &H2A00                         'Function 2AH (Get Date)
   Interrupt &H21, IRegs, ORegs              'Call DOS
   al% = ORegs.ax AND &HFF                   'extract al register
   DOW$ = MID$("SunMonTueWedThuFriSat", (al% + 1) * 3 - 2, 3)
END FUNCTION
=============================== End code ===============================

If you are using QB 4.5, replace "'qbx.bi'" with 'qb.bi'.  You must also
start QB up with the following command:

   C:\>qb /l

Of course, this will only work if you want the *current* day of the
week.  If you want to get the day of the week for dates other than the
current date, you need to use what are called "serial" dates; what you
do, in essence, is to convert the date into a serial ("in sequence")
number.  Once you have done that, you can do all sorts of calculations
on it.

                                --Joe in Bay Ridge, Brooklyn, NY--
                                      Sun  12-13-1992, 02:01

 * SLMR 2.1a * Tagline Subsystem down at this time...

--- Maximus 2.01wb
 * Origin: * BlueDog BBS * [phone] * NYC FileBone Hub (1:278/709)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #6625
 Date:    12-13-92 02:10 (Public)
 From:    JOE NEGRON
 To:      JOHN GALLAS
 Subject: keyboard repeat speed
────────────────────────────────────────────────────────────────────────────────
JG> Is there any way I can increase the keyboard repeat speed?

Here you go:

============================== Begin code ==============================
DEFINT A-Z

'$INCLUDE: 'qbx.bi'

DECLARE SUB SetKBRate (InitDelay%, RepeatRate%)

SetKBRate 35, 250

SYSTEM

'***********************************************************************
'* SUB SetKBRate
'*
'* PURPOSE
'*    Uses BIOS ISR 16H, Service 03H (Set Typematic Rate and Delay) to
'*    set the typematic rate of an AT keyboard.
'*
'* EXTERNAL ROUTINE(S)
'*    QBX.LIB
'*    -------
'*    SUB Interrupt (IntNum%, IRegs AS RegType, ORegs AS RegType)
'***********************************************************************
SUB SetKBRate (InitDelay%, RepeatRate%) STATIC
   DIM IRegs AS RegType, ORegs AS RegType

   IRegs.ax = &H305
   IRegs.bx = InitDelay% * 256 + RepeatRate%
   Interrupt &H16, IRegs, ORegs
END SUB
=============================== End code ===============================

Make sure that you start QB with the "/L" command line switch.

Note that you *must* have an AT for this routine to work.

                                --Joe in Bay Ridge, Brooklyn, NY--
                                      Sun  12-13-1992, 02:10

 * SLMR 2.1a * Press Esc to load the BBS, or Alt-H for IQ test.

--- Maximus 2.01wb
 * Origin: * BlueDog BBS * [phone] * NYC FileBone Hub (1:278/709)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #6626
 Date:    12-13-92 02:18 (Public)
 From:    JOE NEGRON
 To:      MIKE JASKO
 Subject: pause
────────────────────────────────────────────────────────────────────────────────
MJ> I would like to know how to put a simple pause in a QuickBasic
  > program.  For example, I want it to display a message when the program
  > is ending and I want it to stay on the screen for a certin amount of
  > time.  Thanx in advance!!!

If you have PDS, you can use SLEEP:

   SLEEP number-of-seconds

If you have QB, you can use the following:

============================== Begin code ==============================
DEFINT A-Z

DECLARE SUB Pause (Ticks&)

DECLARE FUNCTION ClockTicks& ()

'Pause for 10 seconds:
Pause 182

SYSTEM

'***********************************************************************
'* FUNCTION ClockTicks&
'*
'* PURPOSE
'*    Returns the number of clock ticks since midnight.
'***********************************************************************
FUNCTION ClockTicks& STATIC
   DEF SEG = &H40
   ClockTicks& = PEEK(&H6C) + PEEK(&H6D) * 256& + PEEK(&H6E) * 65536
   DEF SEG
END FUNCTION

'***********************************************************************
'* SUB Pause
'*
'* PURPOSE
'*    Pauses a specified number of clock ticks.  The clock ticks
'*    approximately 18.2 times per second.
'*
'* INTERNAL ROUTINE(S)
'*    FUNCTION ClockTicks& ()
'***********************************************************************
SUB Pause (Ticks&) STATIC
   D& = ClockTicks& + Ticks&

   IF D& > 1573038 THEN
      D& = D& - 1573039
      DO WHILE ClockTicks& > 1
      LOOP
   END IF

   DO WHILE ClockTicks& < D&
      IF INKEY$ > "" THEN
         EXIT SUB
      END IF
   LOOP
END SUB
=============================== End code ===============================

The only real functional difference between these two methods is that
although PDS's SLEEP will quit if a key is pressed before the specified
period of time elapses, it will *not* remove the key from the keyboard
buffer while my Pause SUB will.

                                --Joe in Bay Ridge, Brooklyn, NY--
                                      Sun  12-13-1992, 02:18

 * SLMR 2.1a * You can observe a lot just by watching.

--- Maximus 2.01wb
 * Origin: * BlueDog BBS * [phone] * NYC FileBone Hub (1:278/709)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #6729
 Date:    12-13-92 06:41 (Public)
 From:    DICK DENNISON
 To:      BOB OEHRLE
 Subject: Date$   ???
────────────────────────────────────────────────────────────────────────────────
BO> While in Dos if I call for the date I get Wed-12-12-92. If I print
BO> date$ in qb4.5 I get 12-12-92.  Is there away that I can get the days
BO> to print ?? It seems that if I use Mid$ function I can't extract Wed .
BO> I'm trying to write a calendar routine that will alert me at start up
BO> every wednesday to preform a particular job.
BO> Bob in NJ

'Try this:

'Day of Week - Dick Dennison 10/26/89
'$INCLUDE: 'qb.bi'    'load qb with the /L switch
'Interrupt 21 Function 2AH - get date
DIM InRegs AS RegType, OutRegs AS RegType
DIM Day(7) AS STRING * 3
Day$(0) = "Sun": Day$(1) = "Mon": Day$(2) = "Tue": Day$(3) = "Wed"
Day$(4) = "Thu": Day$(5) = "Fri": Day$(6) = "Sat"
CLS
InRegs.ax = &H2A * 256   '2Ah in ah
CALL INTERRUPT(&H21, InRegs, OutRegs)
' * * * cx is the year, dh is the month, dl is the date, al is the day
PRINT OutRegs.cx; " = year"
PRINT OutRegs.dx \ 256; " = month"
PRINT OutRegs.dx MOD 256; " = date"
daynum% = OutRegs.ax MOD 256
PRINT "Day of the week is "; Day$(daynum%)


--- VP [DOS] V4.09e
 * Origin: The MailMan  [phone] NY Quick Share Pt #7 *HST (1:272/34)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #8170
 Date:    12-13-92 18:57 (Public)
 From:    PETER BARNEY
 To:      CRUZ MONCIVAIS
 Subject: Loading .GIF and .PCX
────────────────────────────────────────────────────────────────────────────────
 >  PB> Your reply chain got tangled.  You should've sent the reply to Harry
 >  PB> Gish. He did post some code for 256-pcx though.  Did you get it?

 >  No I did not get that code?   Is it possible to re-post?

I don't have the EXACT original code (it was written in ZBASIC, I converted
to QB), hope you don't mind Harry.

'(1127)  Sat 21 Nov 92  1:56p
'By: Harry Gish
'To: All
'Re: 256 color PCX reader
'St:
'---------------------------------------------------------------------------

DEFINT A-Z
SCREEN 13

FileName$ = "256COLOR.PCX"  'fill in the blank
OPEN FileName$ FOR BINARY AS #2 LEN = 11
'Size# must be set to actual PCX file size in bytes
Size# = LOF(2)

'The first 128 bytes in the file are a header.
'Much of it is unused, or of no practical use.
'For simplicity we'll cover the important ones only.

header$ = SPACE$(128)
GET #2, , header$: CLS

'The first position is a PCX 'signature'.

Sig$ = LEFT$(header$, 1)
IF Sig$ <> CHR$(10) THEN PRINT "Invalid PCX file, no ZSoft header found": END

'The next header byte specifies the version.
'For 256 color it must be 5.

Ver$ = MID$(header$, 2, 1): Ver = ASC(Ver$)
IF Ver <> 0 AND Ver <> 2 AND Ver <> 3 AND Ver <> 5 THEN PRINT "Invalid
version number": END

'The next header byte specifies the color bits.
'For 256 color it must be 8.

ColorBits$ = MID$(header$, 4, 1): ColorBits = ASC(ColorBits$)
IF ColorBits <> 1 AND ColorBits <> 8 THEN PRINT "Invalid number of color
bits": END

'The image size is contained in 4 bytes
'starting at position 9 of the header.

XRes$ = MID$(header$, 9, 2)
XRes1$ = LEFT$(XRes$, 1): XRes2$ = RIGHT$(XRes$, 1)
XRes = ASC(XRes1$) + ASC(XRes2$) * 256 + 1

YRes$ = MID$(header$, 11, 2)
YRes1$ = LEFT$(YRes$, 1): YRes2$ = RIGHT$(YRes$, 1)
YRes = ASC(YRes1$) + ASC(YRes2$) * 256 + 1

'256 Color PCX

Bytes# = 128
Pointer = 0

'The palette information (definitions of the 256 colors)
'is contained in the last 768 bytes of the file. There
'is a "leading check-byte" of 0C (hex) preceding it.
'Here we're positioning to that check-byte.

SEEK #2, Size# - 769
a$ = " "
GET #2, , a$

'Now we read the next 768 bytes {256 x 3 for Red,
'Green and Blue definitions respectively}. Current
'paletting for PCX requires division by 4. If there
'is a "true-color" PCX format {and there may be and
'I don't know about it} I'd expect it to simply drop
'the division by 4 and make it the actual number.

FOR X = 0 TO 255
    a$ = "   "
    GET #2, , a$
    R = (ASC(MID$(a$, 1, 1)) / 4) AND 63
    G = (ASC(MID$(a$, 2, 1)) / 4) AND 63
    B = (ASC(MID$(a$, 3, 1)) / 4) AND 63
    PALETTE X, R + G * 256 + B * 65536
NEXT

'Now we position at the 128th byte,
'which is where the data begins.

SEEK #2, 128

'Read a byte

DecodeGroup:
X$ = " "
IF EOF(2) THEN GOTO done
GET #2, , X$: X = ASC(X$): Bytes# = Bytes# + 1

'Now we must see if the byte represents a single color
'value or if it is a multiplier value. A quirk of 256
'COLOR PCX's is that a single value of the top 64 colors
'must be encoded as a multiplier of 1 times the color.
'You can't say COLOR 255, you must say 1 times 255. This
'makes many 256 color PCX files actually larger than a
'simple value dump. In this case if the byte value is
'less than 193 then it is an actual value.

'LONGIF ? - Harry, what the heck does LONGIF mean?
IF X < 193 THEN
    PSET (Pointer, LineNo), X
    Pointer = Pointer + 1
END IF

'Otherwise we interpret it as a multiplier.
'Multiplier value can be as large as 63.

'LONGIF ? - again?
IF X > 192 THEN
    X = X - 192:
    X$ = " "
    GET #2, , X$: y = ASC(X$): Bytes# = Bytes# + 1
    LINE (Pointer, LineNo)-(Pointer + X - 1, LineNo), y
    Pointer = Pointer + X
END IF

'Pointer notes the current position in the X line scan.
'When the line is done Pointer gets reset to zero.

IF Pointer < XRes GOTO DecodeGroup
Pointer = 0

'If we're at end of line now we need to see if all lines are decoded.
'If so we end, otherwise we start processing the next line.

IF LineNo = YRes GOTO done

LineNo = LineNo + 1
GOTO DecodeGroup

done:
BEEP
WHILE INKEY$ = "": WEND
SCREEN 2, 1: SCREEN 0, 0: COLOR 15, 1, 4: CLS : END

--- FMail 0.92
 * Origin: Pete's Place - Toledo, Ohio (1:234/35.1)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #8174
 Date:    12-13-92 19:31 (Public)
 From:    PETER BARNEY
 To:      JOHN GALLAS
 Subject: keyboard repeat speed
────────────────────────────────────────────────────────────────────────────────
 > Is there any way I can increase the keyboard repeat speed?

'$INCLUDE: 'QBX.BI' or QB.BI
SUB KeySpeed (rate, delay)

'Sets the cursor typematic keyrate.  Rate is the speed at which
'the keys repeat, the range is from 0 to 31, 0 being fastest.
'Delay is the amount of time in 250 millisecond parts before the
'keys begin to repeat.  The range is from 0 to 3, 0 being the
'shortest wait.

DIM Regs AS RegType
Regs.ax = &H305
Regs.bx = (delay AND 3) * 256 + (rate AND 31)
CALL Interrupt(&H16, Regs, Regs)
END SUB

--- FMail 0.92
 * Origin: Pete's Place - Toledo, Ohio (1:234/35.1)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #3811
 Date:    12-12-92 04:23 (Public)
 From:    DAVE NAPLES
 To:      STEVE DEMO
 Subject: directory tree
────────────────────────────────────────────────────────────────────────────────
│» I do have one question, Is it possible to find out what Drive and Dir
│» you are in with out doing the following:
╘═══════════════════════════════════════════════════════════════════════════

    Two interrupts allow you to do these things. Remember, you have to have
the QB library loaded into the environment:

'$INCLUDE: 'QB.BI'      'Include definitions for INTERRUPT and
                        'INTERRUPTX

DIM regs AS RegType, regsx AS RegTypeX
                        'Dimension user-defined arrays

FindDir



SUB FindDir ()

regsx.ax = &H1900       'Load the value 19H into the high byte of
                        'the AX register

INTERRUPTX &H21, regsx, regsx
                        'Call the interrupt

drive = VAL("&H" + RIGHT$(HEX$(regsx.ax), 2))
                        'Assign the returned drive number to the
                        'variable «drive». 0 = A:, 1 = B:, etc.

DIM buffer AS STRING * 128
                        'Allocate a buffer to store the returned
                        'path name

regsx.ax = &H4700       'Load the high byte of the AX register with
                        'the value 47H

regsx.dx = drive        'Load the drive number into the low byte of
                        'the DX register

regsx.ds = VARSEG(buffer)
                        'Load the data segment address of the
                        'buffer into the DS register

regsx.si = VARPTR(buffer)
                        'Load the offset address of the buffer into
                        'the SI register

INTERRUPTX &H21, regsx, regsx
                        'Call the interrupt

IF (regsx.flags AND 1) = 0 then                 'If the operation
    LOCATE 1, 1: PRINT "DIRECTORY FOUND"        'was completed
ELSE                                            'successfully
    LOCATE 1, 1: PRINT "DEVICE UNAVAILABLE"
END IF
END SUB

    This should do the trick. It also goes a helluva lot faster
than shelling to DOS, writing a sequential file, then reading from the file.
Hope it helps.




                        The Resident Scholar

 ■ MegaMail 2.10 #0:"Can't we all just get along?" - G.A. Custer

--- SLMAIL v3.0/WL  (#0109)
 * Origin: Burleigh's BBS - 703-898-8153/898-2980 Philez,Jamez,Mzgz,K-Rad!
(1:274/6)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #3812
 Date:    12-14-92 17:39 (Public)
 From:    DAVE NAPLES
 To:      MARK BUTLER
 Subject: Alphabetizer FUNCTION
────────────────────────────────────────────────────────────────────────────────
│» How would you combine two string arrays? I am writing a program that
│» needs to combine the filespec matches from the current directory with
│» those found in another into one filename array and display the result
│» for a tag-list. I came up with something that halfway works but
│» looking back over my spaghetti pile of code I figgered "there has to
│» be any easier, cleaner way than this!" ... you know of an easy way to
│» append two such arrays?
╘═══════════════════════════════════════════════════════════════════════════

    Try this fer size:

DIM array1(100), array2(100), array3(200)
    :
    :
    :
    :
    :program code
    :
    :
    :
    :
FOR A = 1 TO 200
FOR B = 1 TO 100
array3(A) = array1(B)
NEXT B
FOR C = 1 TO 100
array3(A) = array2(C)
NEXT C
NEXT A

    Kind of a kludge, but it'll work ...



                        The Resident Scholar

 ■ MegaMail 2.10 #0:Fer pete's sake, don't try this tagline at home!

--- SLMAIL v3.0/WL  (#0109)
 * Origin: Burleigh's BBS - 703-898-8153/898-2980 Philez,Jamez,Mzgz,K-Rad!
(1:274/6)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #3817
 Date:    12-14-92 17:57 (Public)
 From:    DAVE NAPLES
 To:      JOHN WOODGATE
 Subject: Looking for code
────────────────────────────────────────────────────────────────────────────────
│»I know 3 ways to get that information, here's the pathetic way.
╘═══════════════════════════════════════════════════════════════════════════

    The NON-pathetic way runs thusly (remember, ya gotta have
QB.LIB ta run this:)

'$INCLUDE: 'qb.bi'

DIM regs AS RegType, regsx AS RegTypeX

regsx.ax = &H1A00
INTERRUPTX &H10, regsx, regsx
vmode = VAL("&H" + RIGHT$(HEX$(regsx.bx), 2))
SELECT CASE vmode
    CASE 0
        monitor$ = "No card installed"
    CASE 1
        monitor$ = "MDA Display"
    CASE 2
        monitor$ = "CGA Display"
    CASE 4
        monitor$ = "EGA or EGA Mutlisync Display"
    CASE 5
        monitor$ = "EGA Mono Display"
    CASE 7
        monitor$ = "VGA Analog Mono Display"
    CASE 8
        monitor$ = "VGA Analog or VGA Analog Multisync Display"
    CASE 255
        monitor$ = "Unknown Video Card Type"
END SELECT

    That does the trick. Hope it helps.


                        The Resident Scholar

 ■ MegaMail 2.10 #0:"Do me WILD, baby!" - P. Schlafly

--- SLMAIL v3.0/WL  (#0109)
 * Origin: Burleigh's BBS - 703-898-8153/898-2980 Philez,Jamez,Mzgz,K-Rad!
(1:274/6)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #4053
 Date:    12-17-92 11:27 (Public)
 From:    CORIDON HENSHAW
 To:      ERIC B. FORD
 Subject: *.MSG
────────────────────────────────────────────────────────────────────────────────
Hello Eric!

In a msg of <15 Dec 92>, Eric B. Ford writes to Coridon Henshaw:

 >> For storing data that isn't in the header, use a kluge
 >> line.  The only "rule" is that they start with a
 >> CHR$(1) and have no CR or LF on the end.  Here's two
 >> examples from your message:

 >>  EBF> @MSGID: 1:3632/1.6 ab175def

 EBF> Ok, but how to I have a carrage return if I don't put one in?

Hold your questions.  I'm posting the FTSC standard for messages.  200+ lines
folow.

===Chop===
[...]
   4. Data Description

      A  language  specific  notation  was avoided.  Please help  stamp  out
      environmental  dependencies.   Only  you  can  prevent  PClone  market
      dominance.  Don't panic, there are rectangular record layouts too.

      (* non-terminals *)
      UpperCaseName - to be defined further on

      (* literals *)
      "ABC"         - ASCII character string, no termination implied
      nnH           - byte in hexadecimal

      (* terminals *)
      someName      - 16-bit integer, low order byte first (8080 style)
      someName[n]   - field of n bytes
      someName[.n]  - field of n bits
      someName(n)   - Null terminated string allocated n chars (incl Null)
      someName{max} - Null terminated string of up to max chars (incl Null)

      (* punctuation *)
      a b           - one 'a' followed by one 'b'
      ( a | b )     - either 'a' or 'b', but not both
      { a }         - zero or more 'a's
      [ b ]         - zero or one 'b'
      (* comment *) - ignored

      (* predeclared constant *)
      Null          = 00H
[...]
   1. Application Layer Data Definition : a Stored Message

                               Stored Message

       Offset
      dec hex
              .-----------------------------------------------.
        0   0 |                                               |
              ~                 fromUserName                  ~
              |                   36 bytes                    |
              +-----------------------+-----------------------+
       36  24 |                                               |
              ~                  toUserName                   ~
              |                   36 bytes                    |
              +-----------------------+-----------------------+
       72  48 |                                               |
              ~                    subject                    ~
              |                   72  bytes                   |
              +-----------------------+-----------------------+
      144  90 |                                               |
              ~                    dateTime                   ~
              |                    20 bytes                   |
              +-----------------------+-----------------------+
      164  A4 | timesRead (low order) | timesRead (high order)|
              +-----------------------+-----------------------+
      166  A6 | destNode (low order)  | destNode (high order) |
              +-----------------------+-----------------------+
      168  A8 | origNode (low order)  | origNode (high order) |
              +-----------------------+-----------------------+
      170  AA |   cost (low order)    |   cost (high order)   |
              +-----------------------+-----------------------+
      172  AC | origNet (low order)   | origNet (high order)  |
              +-----------------------+-----------------------+
      174  AE | destNet (low order)   | destNet (high order)  |
              +-----------------------+-----------------------+
      176  B0 |                     fill                      |
              ~                    8 bytes                    ~
              +-----------------------+-----------------------+
      184  B8 |  replyTo (low order)  |  replyTo (high order) |
              +-----------------------+-----------------------+
      186  BA | Attribute (low order) | Attribute (high order)|
              +-----------------------+-----------------------+
      188  BC | nextReply (low order) | nextReply (high order)|
              +-----------------------+-----------------------+
      190  BE |                      text                     |
              ~                    unbounded                  ~
              |                 null terminated               |
              `-----------------------------------------------'


                                                                           4


      Message    = fromUserName(36)  (* Null terminated *)
                   toUserName(36)    (* Null terminated *)
                   subject(72)       (* see FileList below *)
                   DateTime          (* message body was last edited *)
                   timesRead
                   destNode          (* of message *)
                   origNode          (* of message *)
                   cost              (* in lowest unit of originator's
                                        currency *)
                   origNet           (* of message *)
                   destNet           (* of message *)
                   fill[8]
                   replyTo           (* msg to which this replies *)
                   AttributeWord
                   nextReply         (* msg which replies to this *)
                   text(unbounded)   (* Null terminated *)

      DateTime   = (* a character string 20 characters long *)
                                     (* 01 Jan 86  02:34:56 *)
                   DayOfMonth " " Month " " Year " "
                   " " HH ":" MM ":" SS
                   Null

      DayOfMonth = "01" | "02" | "03" | ... | "31"   (* Fido 0 fills *)
      Month      = "Jan" | "Feb" | "Mar" | "Apr" | "May" | "Jun" |
                   "Jul" | "Aug" | "Sep" | "Oct" | "Nov" | "Dec"
      Year       = "01" | "02" | .. | "85" | "86" | ... | "99" | "00"
      HH         = "00" | .. | "23"
      MM         = "00" | .. | "59"
      SS         = "00" | .. | "59"

      AttributeWord   bit       meaning
                      ---       --------------------
                        0  +    Private
                        1  + s  Crash
                        2       Recd
                        3       Sent
                        4  +    FileAttached
                        5       InTransit
                        6       Orphan
                        7       KillSent
                        8       Local
                        9    s  HoldForPickup
                       10  +    unused
                       11    s  FileRequest
                       12  + s  ReturnReceiptRequest
                       13  + s  IsReturnReceipt
                       14  + s  AuditRequest
                       15    s  FileUpdateReq

                             s - this bit is supported by SEAdog only
                           + - this bit is not zeroed before packeting

      Bits numbers ascend with arithmetic significance of bit position.

----------------------------------------------------------
---------------------
      Message Text

      Message text is unbounded and null terminated (note exception below).

      A 'hard' carriage return, 0DH,  marks the end of a paragraph, and must
      be preserved.

      So   called  'soft'  carriage  returns,  8DH,  may  mark  a   previous
      processor's  automatic line wrap, and should be ignored.  Beware  that
      they may be followed by linefeeds, or may not.

      All  linefeeds, 0AH, should be ignored.  Systems which display message
      text should wrap long lines to suit their application.

      If the first character of a physical line (e.g. the first character of
      the  message text, or the character immediately after a hard  carriage
      return (ignoring any linefeeds)) is a ^A (<control-A>, 01H), then that
      line  is  not  displayed  as  it  contains  control  information.  The
      convention for such control lines is:
        o They begin with ^A
        o They end at the end of the physical line (i.e. ignore soft <cr>s).
        o They begin with a keyword followed by a colon.
        o The keywords are uniquely assigned to applications.
        o They keyword/colon pair is followed by application specific data.

      Current ^A keyword assignments are:
      o TOPT <pt no> - origin point address
      o FMPT <pt no> - origin point address
      o INTL <dest z:n/n> <orig z:n/n> - used for inter-zone address

      In  order to provide minimal support for NAPLPS graphics, applications
      should  display without interpretation  any bytes found between  ????,
      ??H,  and ????, ??H.  The surrounded  data bytes may be any eight  bit
      characters  with the exception of  the terminating byte, ??H.  Do  not
      strip carriage returns, soft or hard, or linefeeds.

----------------------------------------------------------
---------------------
      File Specifications

      If  one  or more  of FileAttached, FileRequest, or  FileUpdateReq  are
      asserted  in an AttributeWord, the subject{72} field is interpreted as
      a  list of file specifications  which may include wildcards and  other
      system-dependent data.  This list is of the form

      FileList = [ FileSpec { Sep FileSpec } ] Null

      FileSpec = (* implementation dependent file specification.  may
                    not contain Null or any of the characters in Sep. *)

      Sep      = ( " " | "," )  { " " }




      There are deviations from and additions to these specifications

      1  - Fido does not necessarily terminate the message text with a Null,
           but uses an empty line (0DH 0AH 0DH 0AH)

      2 - SEAdog zeros the message cost field when building a message.

      4 - SEAdog uses a different format for dates, e.g.

      DateTime   = (* a character string 20 characters long *)
                       (* SEAdog format Mon  1 Jan 86 02:34 *)
                   DayOfWk " " DayOfMo " " Month " " Year "
                   " HH ":" MM Null

      DayOfWeek  = "Mon" | "Tue" | "Wed" | "Thu" | "Fri" | "Sat" | "Sun"
      DayOfMon   = " 1" | " 2" | " 3" | ... | "31"  (* blank fill *)

===CHOP===

Coridon Henshaw

Sirrus| /
    --*--
    / |Software

...Taco Bell is not a Mexican phone company.

--- GEcho 1.00
 * Origin: TCS Concordia - Mail Only - Toronto, Ontario (1:250/820)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #4365
 Date:    12-17-92 20:50 (Public)
 From:    STEVE DEMO
 To:      ANDY C. OLIVER
 Subject: DIRECTORY TREE
────────────────────────────────────────────────────────────────────────────────
 -=> Quoting Andy C. oliver to Steve Demo <=-

 ACo> You might try a Library, such as Tom Hanlin's PBCLONE.  PBCLONE17 is
 ACo> the latest to date (as far as I know), and it has such routines.  As
 ACo> do many other good libraries.
 ACo> ACO

 Hello,

 I have used Pbclone before just was curious if QB could do it by it's self.
 I would like to learn all about QB with out useing any libarys. But I did
 get some code to do it . This was Given to me By Rick Cooper.

 ==========================<cut here>========================================
DECLARE FUNCTION CurrentDir$ ()

FUNCTION CurrentDir$
DEFSNG A-Z
DIM InRegs AS RegTypeX, OutRegs AS RegTypeX
'====================================================================
' This Function Will Return The Current Path With A Complete Path Spec
' Including Drive And Trailing "\"
' If You Don't Want The trailing "\" Then Use A Left$ Statement To
'Remove It... E.G. Dir$ = Left$(CurrentDir$,Len(CurrentDir$) - 1)
'===================================================================

InRegs.ax = &H1900                         'Use Dos Function To Get
CALL INTERRUPTX(&H21, InRegs, OutRegs)     'Current Drive
drive% = (OutRegs.ax AND &HFF) + 1         'Function Returns 0 Based
                                           'Drive Number And Next
                                           'Function needs A 1 Based
                                           'Number So We Add 1 To Result

drive$ = CHR$(64 + drive%)                 'Create String Representation
                                           'In Uppercase, Of Current
                                           'Drive Number

DIRECTORY$ = SPACE$(64)                    'Create Scratch Buffer

InRegs.ax = (256 * &H47) + 0               'Load Function Number
InRegs.dx = (256 * 0) + drive%             'Load Drive Number
InRegs.ds = VARSEG(DIRECTORY$)             'Pointer To A 64 Byte
InRegs.si = SADD(DIRECTORY$)               'Scratch Buffer
CALL INTERRUPTX(&H21, InRegs, OutRegs)     'Call Dos Int. 21 Func. 47

spot = INSTR(DIRECTORY$, CHR$(0))          'Function Returns An ASCIIZ
IF spot <> 0 THEN                          'String And We Don't Want The
  DIRECTORY$ = LEFT$(DIRECTORY$, spot - 1) 'Terminating Null Character
END IF                                     'So This Removes It And
                                           'Trailing Spaces

IF LEN(DIRECTORY$) > 1 THEN                'If It Isn't The Root Then
                                           'We Add A Trailing "\"

CurrentDir$ = drive$ + ":\" + DIRECTORY$ + "\"

ELSE                                       'If It Is The Root We Don't
CurrentDir$ = drive$ + ":\" + RTRIM$(LTRIM$(DIRECTORY$))
END IF                                     'Done!


END FUNCTION


========================<cut here>==========================================

Just thought I would share what was given to me.


                                                Take it easy,

                                                Steve Demo


... Pardon Me, But Would You Have Any Blue Poupon?
--- Blue Wave/QBBS v2.11 [NR]
 * Origin: Just For The Heck Of It II   -=(Fort Wayne In)=- (1:236/16.0)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #8229
 Date:    12-21-92 15:43 (Public)
 From:    TONY ELLIOTT
 To:      STEVE PERRY
 Subject: FCB's
────────────────────────────────────────────────────────────────────────────────
Steve,

 SP> This is probably a dumb question, but here it goes. I need to get the
 SP> size of a file. I'm currently doing a shell command and directing it
 SP> to a file that I open and then search for the needed data. I was
 SP> looking through a interrupts book and it shows that interrupt 21h with
 SP> ah = 23h and ds:dx = pointer to an unopened file control block. Can
 SP> this be done in PDS? If so how? How do you access a FCB anyway?
 SP> Any and all help would be appreciated!

The easiest way is to open the file for input and look at LOF:

    OPEN "ThisFile.Dat" FOR INPUT AS #1
    Length& = LOF(1)
    CLOSE #1

If you are going to use an interrupt call instead, I'd recommend the
Find First function (4Eh) instead. That'll load the DTA area with
with the file length, date, time, and attribute. Such code could be
easily modified to get directory names, volume labels, and even to load
an array with a list of files based on a filespec. Here's some code to
get some info about a specific file. You'll need to load the standard
QBX.QLB when starting the IDE. If you are using QB4.x instead, change
the $INCLUDE to "QB.BI":

DEFINT A-Z
REM $INCLUDE: 'QBX.BI'
TYPE Dta
    Dummy1  AS STRING * 21
    Attr    AS STRING * 1
    FTime   AS INTEGER
    FDate   AS INTEGER
    FLen    AS LONG
    FilName AS STRING * 13
END TYPE

FUNCTION FileInfo% (FileName$, FilDate$, FilTime$, Attr%, Length&)

    DIM LclDta AS Dta, Reg AS RegTypeX
    DIM TempFil AS STRING * 68

    'Get the current DTA address and save it.
    Reg.AX = &H2F00
    CALL InterruptX(&H21, Reg, Reg)
    OldDtaSeg = Reg.ES
    OldDtaOfs = Reg.BX

    'Change the DTA to avoid screwing up any work BASIC may be
    'doing when this function was invoked (DIR$, for example).
    Reg.AX = &H1A00
    Reg.DS = VARSEG(LclDta)             'Point DTA to our structure
    Reg.DX = VARPTR(LclDta)
    CALL InterruptX(&H21, Reg, Reg)

    'We use a fixed-length string to hold an ASCIZ copy of the file
    ' name. We don't use a convention string because then the code
    ' would have to be customized for QB/PDS/VBDOS. This way, one
    ' version works with all.

    TempFil = FileName$ + CHR$(0)

    Reg.AX = &H4E00                     'Find First
    Reg.CX = 32                         'Normal and "archive" files
    Reg.DS = VARSEG(TempFil)            'Address of our FL ASCIZ string
    Reg.DX = VARPTR(TempFil)
    CALL InterruptX(&H21, Reg, Reg)

    IF Reg.Flags AND 1 THEN
        Status% = Reg.AX
    ELSE
        Status% = 0
        Yr$ = LTRIM$(STR$((PEEK(VARPTR(LclDta.FDate) + 1) AND &HFE) \ 2 +
1980))
        Mon$ = LTRIM$(STR$((LclDta.FDate AND &H1E0) \ 32))
        Dy$ = LTRIM$(STR$(LclDta.FDate AND &H1F))
        FileDate$ = Mon$ + "/" + Dy$ + "/" + Yr$
        Sec$ = LTRIM$(STR$((LclDta.FTime AND &H1F) * 2))
        Min$ = LTRIM$(STR$((LclDta.FTime AND &H7E0) \ 32))
        Hr$ = LTRIM$(STR$((PEEK(VARPTR(LclDta.FTime) + 1) AND &HF8) \ 8))
        FileTime$ = Hr$ + ":" + Min$ + ":" + Sec$
        Attr = ASC(LclDta.Attr)
        Length& = LclDta.FLen
    END IF

    Reg.AX = &H1A00                     'Restore the old DTA address
    Reg.DS = OldDtaSeg
    Reg.DX = OldDtaOfs
    CALL InterruptX(&H21, Reg, Reg)

END FUNCTION

To use it, just:
 DECLARE FUNCTION FileInfo%(FileName$, FilDate$, FilTime$, Attr%, Length&)
 Status% = FileInfo%("\AUTOEXEC.BAT", FilDate$, FilTime$, Attr%, Length&)
 IF Status% THEN
    PRINT "DOS Error";Status%;"occurred!"
 ELSE
    PRINT FilDate$,FilTime$,FilAttr%,Length&
 END IF

--- Blue Wave/Max v2.10 [NR]
 * Origin: Oakland BBS - McDonough, GA - [phone] (1:133/706.0)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #5565
 Date:    12-24-92 15:38 (Public)
 From:    LUIS ESPINOZA
 To:      JEFFERY FOY
 Subject: 4DOS and detecting it
────────────────────────────────────────────────────────────────────────────────
On (21 Dec 92) Jeffery Foy wrote to All...

 JF> I'd like to add 4DOS support in a program that I'm writing. How can
 JF> you
 JF> detect it from BASIC? Is there a special call or something? I thought
 JF> about just looking for 4DOS.COM in the PATH but that seems a bit
 JF> tacky.
 JF>

        Try something like:

          a$=Environ$("COMSPEC")
          if instr(a$,"4DOS") then FFos=1 else FFos=0

                                        Luis


--- PPoint 1.33
 * Origin: The Rubber Room (1:207/213.5)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #6645
 Date:    12-27-92 12:27 (Public)
 From:    DIK COATES
 To:      CORIDON HENSHAW
 Subject: scroll part 1 of 3
────────────────────────────────────────────────────────────────────────────────
 >>>> QUOTING Coridon Henshaw to Dik Coates <<<<

 DC> You talkin' text mode, or graphics mode... Text mode, I have a series
 DC> of routines I will upload if you want...
 CH> I'd like to see that.  Both upward and downward, please ;>

Here goes... Will set it up in three chunks...

The first file converts a normal ASCII file to one that can be read
as a binary file.

- - - - - - - - - - - -  Cut on Dashed Line - - - - - - - - - - - - -

DECLARE FUNCTION FILEEXIST% (filename$)
DECLARE SUB CommandLine (narg%, arg$())

  REDIM arg$(32)
  CALL CommandLine(narg%, arg$())
  CLS


  IF narg% <> 0 THEN
    REDIM PRESERVE arg$(narg%)

    IF narg% > 2 THEN
      LOCATE 12, 25
      PRINT "Too many arguments on Command Line"
      LOCATE 23, 21
      PRINT ">>>>>  Press Any Key to Exit to DOS  <<<<<";

      DO
        a$ = INKEY$
      LOOP UNTIL LEN(a$)

      CLS
      END
    END IF

    IF narg% < 2 THEN
      LOCATE 12, 25
      PRINT "Insufficient arguments on Command Line"
      LOCATE 23, 21
      PRINT ">>>>>  Press Any Key to Exit to DOS  <<<<<";

      DO
        a$ = INKEY$
      LOOP UNTIL LEN(a$)

      CLS
      END
    END IF

    IF NOT FILEEXIST%(arg$(1)) THEN
      LOCATE 12, 25
      PRINT "Text File does not Exist"
      LOCATE 23, 21
      PRINT ">>>>>  Press Any Key to Exit to DOS  <<<<<";

      DO
        a$ = INKEY$
      LOOP UNTIL LEN(a$)

      CLS
      END
    ELSE
      filenum1% = FREEFILE
      OPEN arg$(1) FOR INPUT AS #filenum1%
      filenum2% = FREEFILE
      OPEN arg$(2) FOR BINARY AS #filenum2%

      DO WHILE NOT EOF(filenum1%)
        LINE INPUT #filenum1%, strdummy$
        count% = count% + 1
      LOOP

      CLOSE #filenum1%
      PUT #filenum2%, , count%

      filenum1% = FREEFILE
      OPEN arg$(1) FOR INPUT AS #filenum1%

      FOR c% = 1 TO count%
        LINE INPUT #filenum1%, strdummy$
        lendummy% = LEN(strdummy$)
        PUT #filenum2%, , lendummy%
        PUT #filenum2%, , strdummy$
      NEXT c%

    END IF
  ELSE
    CLS
    LOCATE 12, 25
    PRINT "USAGE:  FASC2BIN textfile binfile"
    LOCATE 23, 21
    PRINT ">>>>>  Press Any Key to Exit to DOS  <<<<<";

    DO
      a$ = INKEY$
    LOOP UNTIL LEN(a$)
  END IF

  CLS
  END

- - - - - - - - - - - -  Cut on Dashed Line - - - - - - - - - - - - -

... That tagline is TRUE ->  <- That tagline is FALSE
___ Blue Wave/QWK v2.10

--- Maximus 2.00
 * Origin: Durham Systems (ONLINE!) (1:229/110)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #6646
 Date:    12-27-92 12:27 (Public)
 From:    DIK COATES
 To:      CORIDON HENSHAW
 Subject: scroll part 2 of 3
────────────────────────────────────────────────────────────────────────────────
This is the second bunch.... of 3

It has routines used with the first listing...

- - - - - - - - - - - - - -  Cut on Dashed Line - - - - - - - - - - -


'************************************************************ SUB CommandLine
'
' Procedure returns command line arguments.  Arguments must be separated by
' spaces, tabs, or "/".  A maximum of 32 arguments can be returned in a
' array.  The array must be declared as a dynamic array from the calling
' program.
'
' ARG:  NUL
' RET:  narg%   - number of arguments on the command line
'       arg$()  - string array listing arguments
' COMP: MS BASIC 7.1
' REV:  91-10-28 header format
'
'****************************************************************************
'
SUB CommandLine (narg%, arg$())

  cl$ = COMMAND$
  l% = LEN(cl$)

  FOR c% = 1 TO l%
    temp$ = MID$(cl$, c%, 1)

    IF temp$ = " " OR temp$ = CHR$(9) OR temp$ = "/" THEN
      flag% = 0
    ELSE
      IF NOT flag% THEN
        narg% = narg% + 1
        flag% = -1
      END IF

      arg$(narg%) = arg$(narg%) + UCASE$(temp$)
    END IF
  NEXT c%

END SUB' CommandLine

'******************************************************** FUNCTION FILEEXIST%
'
' Procedure determines if a file exists.  If file exists, then a -1 is
' returned, otherwise a 0 is returned.  Procedure avoids using ON ERROR call.
'
' CALL: FILEEXIST% (filename$)
'
' ARG:  filename$ - full path and filename of file to be tested
'
' COMP: MS Basic 7.1
'
' REV:  91-10-30
'
'****************************************************************************
'
FUNCTION FILEEXIST% (filename$)

  FILEEXIST% = -1

  IF LEN(DIR$(filename$)) = 0 THEN
    FILEEXIST% = 0
  END IF

END FUNCTION






'******************************************************** SUBPROGRAM ScrollDn
'
'   Procedure scrolls the display window specified by the top and bottom rows
'   and the left and right columns down by a number of declared rows.  The
'   space left behind is changed to the colour attribute of the background.
'
'   CALL:   ScrollDn (trow%, icol%, brow%, fcol%, numrow%, bga%)
'
'   ARG:  trow%   =   top row of window to be scrolled
'         icol%   =   initial column of window
'         brow%   =   bottom row of window
'         fcol%   =   final column of window
'         numrow% =   number of rows to be scrolled down
'         bga%    =   background colour attribute
'
'   USES: Interrupt()
'
'   COMP: MS Basic 7.1
'
'   LIB:  DOS.LIB/QLB
'
'   REV:  91-11-13
'
'****************************************************************************
'
SUB ScrollDn (trow%, icol%, brow%, fcol%, numrow%, bga%)

  DIM InReg AS RegType, OutReg AS RegType

  tr% = trow% - 1
  ic% = icol% - 1
  br% = brow% - 1
  fc% = fcol% - 1
  temp% = bga%

  IF temp% < 0 OR temp% > 15 THEN
    temp% = 0
  END IF

  temp% = temp% * 16
  InReg.ax = 1792 + numrow%
  InReg.bx = temp% * 256
  InReg.cx = tr% * 256 + ic%
  InReg.dx = br% * 256 + fc%
  CALL Interrupt(&H10, InReg, OutReg)

END SUB 'ScrollDn




'******************************************************** SUBPROGRAM ScrollUp
'
'   Procedure scrolls the display window specified by the top and bottom rows
'   and the left and right columns up by a number of declared rows.  The
'   space left behind is changed to the colour attribute of the background.
'
'   CALL:   ScrollUp (trow%, icol%, brow%, fcol%, numrow%, bga%)
'
'   ARG:  trow%   =   top row of window to be scrolled
'         icol%   =   initial column of window
'         brow%   =   bottom row of window
'         fcol%   =   final column of window
'         numrow% =   number of rows to be scrolled up
'         bga%    =   background colour attribute
'
'   USES:   Interrupt()
'
'   COMP:   MS Basic 7.1
'
'   LIB:    DOS.LIB/QLB
'
'   REV:   91-11-13
'
'****************************************************************************
'
SUB ScrollUp (trow%, icol%, brow%, fcol%, numrow%, bga%)

  DIM InReg AS RegType, OutReg AS RegType

  tr% = trow% - 1
  ic% = icol% - 1
  br% = brow% - 1
  fc% = fcol% - 1
  temp% = bga%

  IF temp% < 0 OR temp% > 15 THEN
    temp% = 0
  END IF

  temp% = temp% * 16
  InReg.ax = 1536 + numrow%
  InReg.bx = temp% * 256
  InReg.cx = tr% * 256 + ic%
  InReg.dx = br% * 256 + fc%
  CALL Interrupt(&H10, InReg, OutReg)

END SUB 'ScrollUp



- - - - - - - - - - - - - -  Cut on Dashed Line - - - - - - - - - - -

... Thesaurus: An ancient reptile with an excellent vocabulary.
___ Blue Wave/QWK v2.10

--- Maximus 2.00
 * Origin: Durham Systems (ONLINE!) (1:229/110)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #6647
 Date:    12-27-92 12:27 (Public)
 From:    DIK COATES
 To:      CORIDON HENSHAW
 Subject: scroll part 3 of 3
────────────────────────────────────────────────────────────────────────────────
This is the last of the installments... Part 3 of 3


- - - - - - - - - - - -  Cut on Dashed Line - - - - - - - - - - - - -

'****************************************************** SUBPROGRAM ScrollText
'
' Procedure prints to screen WARNING MESSAGES returned from the various
' program screens.  The messages if greater in number than the permitted
' number of lines on the screen can be scrolled down and up for viewing.
'
' CALL:   ScrollText (a$(), srow%, scol%, frow%, fcol%, txtfga%, txtbga%,
'                     tartln%)
'
' ARG:  a$()    -   text array to be printed to screen
'       srow%   -   start row of the active screen area
'       scol%   -   start column of the active screen area
'       frow%   -   end row of the active screen area
'       fcol%   -   end column of the active screen area
'       txtfga% -   text foreground attribute
'       txtbga% -   text background attribute
'       startln%-   starting line of the text array to be printed
'
' USES: ClearScrollText()
'       ScrollDn()
'       ClearScrollLine()
'       ScrollUp()
'
' COMP: MS Basic 7.1
'
' REV:  91-03-23
'       91-11-14  header revised
'
'****************************************************************************
'
SUB ScrollText (a$(), srow%, scol%, frow%, fcol%, textfga%, textbga%,
startln%)

  COLOR textfga%, textbga%
  scrwidth% = fcol% - scol% + 1
  linesperscreen% = frow% - srow% + 1  'OK
  lenoffile% = UBOUND(a$, 1)  'OK

  IF linesperscreen% >= lenoffile% THEN                      'single screen
    CALL ClearScrollText(srow%, scol%, frow%, fcol%, textfga%, textbga%)

    FOR c% = 1 TO lenoffile%                                'print screen
      LOCATE srow% - 1 + c%, scol%
      PRINT a$(c%);
    NEXT c%

    DO                                 'exit single screen on escape only
      DO
        key$ = INKEY$
      LOOP UNTIL LEN(key$)

      IF LEN(key$) = 2 THEN
        BEEP
      ELSEIF LEN(key$) = 1 THEN
        IF ASC(key$) = 27 THEN
          EXIT SUB
        ELSE
          BEEP
        END IF
      END IF
    LOOP
  ELSE                                                    'multiple screens
    maxtoprow% = lenoffile% - linesperscreen% + 1 'OK initialize

    IF startln% + linesperscreen% > lenoffile% THEN
      oldtoprow% = maxtoprow%
      oldbotrow% = lenoffile%
    ELSE
      oldtoprow% = startln%
      oldbotrow% = startln% + linesperscreen% - 1
    END IF

    FOR c% = 1 TO linesperscreen%                           'print screen
      LOCATE srow% - 1 + c%, scol%
      PRINT a$(oldtoprow% - 1 + c%);
    NEXT c%

    DO
      DO
        key$ = INKEY$
      LOOP UNTIL LEN(key$)

      IF LEN(key$) = 2 THEN
        temp% = ASC(RIGHT$(key$, 1))

        SELECT CASE temp%
          CASE 71 'home
            scrollflag% = 0
            oldtoprow% = 1
            oldbotrow% = linesperscreen%
          CASE 72 AND oldbotrow% <= linesperscreen% 'cursor up
            scrollflag% = 2
          CASE 72 AND oldbotrow% > linesperscreen%
            scrollflag% = 1
            oldtoprow% = oldtoprow% - 1
            oldbotrow% = oldbotrow% - 1
          CASE 73 AND oldtoprow% <= linesperscreen% 'page up
            scrollflag% = 0
            oldtoprow% = 1
            oldbotrow% = linesperscreen%
          CASE 73 AND oldtoprow% > linesperscreen%
            scrollflag% = 0
            oldtoprow% = oldtoprow% - linesperscreen%
            oldbotrow% = oldbotrow% - linesperscreen%
          CASE 79 'end
            scrollflag% = 0
            oldtoprow% = maxtoprow%
            oldbotrow% = lenoffile%
          CASE 80 AND oldtoprow% < maxtoprow% 'cursor down
            scrollflag% = -1
            oldtoprow% = oldtoprow% + 1
            oldbotrow% = oldbotrow% + 1
          CASE 80 AND oldtoprow% = maxtoprow%
            scrollflag% = 2
          CASE 81 AND oldbotrow% >= maxtoprow%'page down
            scrollflag% = 0
            oldtoprow% = maxtoprow%
            oldbotrow% = lenoffile%
          CASE 81 AND oldbotrow% < maxtoprow%
            scrollflag% = 0
            oldtoprow% = oldtoprow% + linesperscreen%
            oldbotrow% = oldbotrow% + linesperscreen%
          CASE ELSE
            BEEP
        END SELECT

        IF scrollflag% = 1 THEN 'movement up
          CALL ScrollDn(srow%, scol%, frow%, fcol%, 1, textbga%)
          CALL ClearScrollLine(srow%, scol%, fcol%, textfga%, textbga%)
          LOCATE srow%, scol%
          PRINT a$(oldtoprow%);
        ELSEIF scrollflag% = -1 THEN 'movement down
          temp% = srow% + linesperscreen% - 1
          CALL ScrollUp(srow%, scol%, frow%, fcol%, 1, textbga%)
          CALL ClearScrollLine(temp%, scol%, fcol%, textfga%, textbga%)
          LOCATE temp%, scol%
          PRINT a$(oldbotrow%);
        ELSEIF scrollflag% = 0 THEN                     'print screen
          CALL ClearScrollText(srow%, scol%, frow%, fcol%, textfga%, textbga%)

          FOR c% = 1 TO linesperscreen%
            LOCATE srow% - 1 + c%, scol%
            PRINT a$(oldtoprow% - 1 + c%);
          NEXT c%
        END IF

        scrollflag% = 0
      ELSE
        temp% = ASC(key$)

        SELECT CASE temp%
          CASE 27 'escape
            EXIT SUB
          CASE ELSE
            BEEP
        END SELECT
      END IF
    LOOP
  END IF

END SUB 'ScrollText



'********************************************************* SUB TextFile2Array
'
' The procedure copies a BINARY text file to a string array.  The format of
' binary file is:  (size%, LENstring1%, string1$, LENstring2%, string2$,...)
' Error handling must be done in the calling program.
'
' CALL: TextFile2Array (filename$, a$())
'
' ARG:  filename$ - name of the BINARY file to be copied
'
' RET:  a$()      - string array containing contents of binary file
'
' COMP: MS Basic 7.1
'
' REV:  91-10-30
'
'****************************************************************************
'
SUB TextFile2Array (filename$, a$())

  filenum% = FREEFILE
  OPEN filename$ FOR BINARY AS filenum%
  GET filenum%, , size%
  REDIM a$(size%)

  FOR c% = 1 TO size%
    GET filenum%, , dummy%
    a$(c%) = INPUT$(dummy%, filenum%)
  NEXT c%
  CLOSE filenum%

END SUB' TextFile2Array

- - - - - - - - - - - -  Cut on Dashed Line - - - - - - - - - - - - -

It's possible to get a smooth scroll... one row of pixels at a time...
but only from graphics mode... I can provide code for this also... but
will take a bit to unravel it from an application... also, done in
assembly... the only way to do graphics... Regards Dik



... AAAAA - American Association Against Acronym Abuse
___ Blue Wave/QWK v2.10

--- Maximus 2.00
 * Origin: Durham Systems (ONLINE!) (1:229/110)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #7266
 Date:    12-27-92 06:19 (Public)
 From:    RICH GELDREICH
 To:      ALL
 Subject: Bload Compressor/1
────────────────────────────────────────────────────────────────────────────────
    I'll get directly to the point: if you use BSAVE and BLOAD to
compress SCREEN 13 images, then this program should be a great help. The
purpose of this program is to compress SCREEN 13 (320x200x256) images to
a BLOAD'able file. To decompress the file, you call a VERY FAST assembly
language decompressor that quickly sets the palette and writes the image
to the screen. It used to be small, until I documented it... Ooops.

'Page 1 of ENCODE13.BAS begins here.
'SCREEN 13 (320x200x256) Screen Compressor (SP1.BAS)
'Public Domain By Rich Geldreich, December 26, 1992

'Anyone  may  use this program in anything they want,  as long as the
'original author(me,  duh)  is  given  credit  where credit is due...
'Thanks.   I'd appreciate a little cash on the side if you  make  any
'money  off a product that uses this program...   :-) If you make any
'neat modifications/optimizations to this program or the ASM decoder,
'I would really like to seem them!

'Description:
'    This simple SCREEN 13  compression  program uses an LZ77 variant
'to compress SCREEN 13 images.  A FAST assembly subroutine is used to
'decompress the image back to the screen.    The  compression  should
'always beat  PCX, and should come fairly close or beat out GIF under
'most cases.
'
'    The assembly decompressor's  speed  is several magnitudes faster
'than the quickest GIF decoder I've seen, VPIC 5.1. (Look how  simple
'it  is  and  you'll know why!) BTW- The output stage of this program
'was optimized for  decoding  speed,   not for compression.   Several
'optimizations could be added to increase this program's  compression
'performance,   such  as  entropy  encoding  on the distance & length
'tokens(which would slow the decoder down immensely),  increasing the
'sizes of the sliding dictionary and look ahead buffers,  and further
'optimizing the  non-greedy  aspect  of  this  LZ77 implementation to
'choose the best character/match combinations to store in the  output
'stream.
'
'    The assembly subroutine is for 286's and  above,   only.    This
'program does NOT work under QuickBASIC,  only PDS and VB/DOS because
'of the use of BYVAL.
'
'    Any  questions,   cash/and  or  death   threats   call   me   at
'(609)-742-8752  2:30pm  -  11:30pm  eastern  time  or  send  a  self
'addressed stamped evelope (SASE) to:
'
'                     Rich Geldreich
'                     410 Market St.
'                     Gloucester City, NJ 08030
'
'Possible  uses of this program:  Use a GIF or PCX converter(or SHELL
'out  to  VPIC)  to  display  the  image  you  want  to  use  in your
'application on SCREEN 13.   Then encode the image with this program.
'You  can  then  instantly  recall  the  image using the fast Decom13
'assembly language subroutine.
DEFINT A-Z
'Declaration  for  the assembly decompressor.   If the area of memory
'passed does not start with  "RG",  the compressed image's signature,
'then this routine will just return without  doing  anything.    This
'prevents your machine from hanging when you pass it a bum pointer.
DECLARE SUB Decom13 (BYVAL InSegment, BYVAL InOffset)

CONST True = -1, False = 0
'A larger buffer size would surely increase compression.
CONST BufferSize = 4096, HashSize = 4096
CONST Null = BufferSize, Threshold = 2, MaxMatch = 273
CONST MaxCompares = 300 'Controls compression ratio vs. speed

'Arrays for LZ77 style compression with multiple linked lists
DIM SHARED RingBuffer((BufferSize + MaxMatch - 1) - 1)
DIM SHARED NextCell((BufferSize + HashSize + 1) - 1)
DIM SHARED LastCell((BufferSize + HashSize + 1) - 1)
'Temp. holding buffer for compression tokens
DIM SHARED CodeBuffer(16 * 3 - 1)

'Misc. stuff
DIM SHARED DoneFlag, xp, yp, xl, yl, xh, yh
DIM SHARED Match.Length, Match.Position, Match.Distance
DIM SHARED IOBuffer$, IOPointer
DIM SHARED CodePointer, CodeCounter, OrMask AS LONG, BitAccum AS LONG

SCREEN 13

'**COMPRESSION EXAMPLE**
RANDOMIZE TIMER
FOR a = 1 TO 100  'draw us some garbage
    x = RND * 319: y = RND * 199: c = RND * 255
    CIRCLE (x, y), RND * 60, c: PAINT (x, y), RND * 255, c
NEXT
FOR a = 1 TO 200: LINE -(RND * 319, RND * 199), RND * 255: NEXT
Compress13 "coolfile.bci" 'compress the screen to coolfile.bci

'**DECOMPRESSION EXAMPLE**
'Allocate 64,000 bytes for a worst case scenario, decrease this of
'course to match the image's compressed size in bytes...
'Continued on page 2

--- MsgToss 2.0b
 * Origin: Computer Co-Op - Voorhees, NJ | Ted Hare (1:266/29)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #7267
 Date:    12-27-92 06:20 (Public)
 From:    RICH GELDREICH
 To:      ALL
 Subject: Bload Compressor/2
────────────────────────────────────────────────────────────────────────────────
'Page 2 of ENCODE13.BAS begins here.
REDIM image(32000): DEF SEG = VARSEG(image(0))
BLOAD "coolfile.bci", VARPTR(image(0)) 'Load the compressed data.

PRINT "Press a key to decompress.": B$ = INPUT$(1): SCREEN 13

'Call the asm routine to decompress the image.
Decom13 VARSEG(image(0)), VARPTR(image(0)): B$ = INPUT$(1)

'Compresses a SCREEN 13 image to a BLOADable file. Use the ASM sub
'Decom13 to decompress the image back to the screen. This routine
'currently crawls, because I didn't optimize it that much.
'The entire palette is also saved to the compressed file,
SUB Compress13 (F$)
    OPEN F$ FOR OUTPUT AS #1: CLOSE : OPEN F$ FOR BINARY AS #1
    'Store the BLOAD header and image signature.
    a$ = CHR$(&HFD) + CHR$(0) + CHR$(&HA0) + STRING$(4, 0) + "RG"
    PUT #1, , a$
    'Initialize a 4k disk output buffer
    IOBuffer$ = SPACE$(4096): IOPointer = 1
    CodePointer = 0: CodeCounter = 0: OrMask = 1: BitAccum = 0
    'Write the screen's palette.
    OUT &H3C7, 0: FOR a = 0 TO 767: WriteByte INP(&H3C9): NEXT

    DoneFlag = False: xl = 0: yl = 0: xh = 319: yh = 199
    xp = xl: yp = yl 'coordinate of next point to compress

    InitRingBuffer   'clear the ring buffer
    InitLZ77         'initialize the linked list pool
    'prime the look ahead buffer
    S = 0: R = BufferSize - MaxMatch
    FOR LookAheadLength = 0 TO MaxMatch - 1
        IF DoneFlag THEN
            EXIT FOR
        ELSE
            RingBuffer(R + LookAheadLength) = GetPixel
        END IF
    NEXT
    'find first string
    FindString R
    DO
        'if match too small(less than 3 chars), the just output
        'a single character
        IF Match.Length <= Threshold THEN
            OutputChar RingBuffer(R): Last.Match.Length = 1
        ELSE
            'output a string match token
            Last.Match.Length = Match.Length
            'Send  the match's distance,  instead of its position in
            'the ring buffer, because the decompressor is not using a
            'ring buffer to store the decompressed data.
            Match.Distance = (R - Match.Position) AND (BufferSize - 1)
            OutputMatch
        END IF
        'prime the look ahead buffer with more characters
        FOR a = 0 TO Last.Match.Length - 1
            IF DoneFlag THEN EXIT FOR 'exit this loop if no more chars
            'delete string at S, then store a new char at S
            DeleteString S: RingBuffer(S) = GetPixel
            'keep a "ghost buffer" at the end of the ring buffer to
            'avoid using a logical AND on all of our buffer pointers
            IF S < (MaxMatch - 1) THEN
                RingBuffer(S + BufferSize) = RingBuffer(S)
            END IF
            S = (S + 1) AND (BufferSize - 1)
            R = (R + 1) AND (BufferSize - 1)
            'if not last time through loop then just add string to the
            'linked list pool, otherwise add it and find a match
            '(this could be optimized so the IF/THEN conditional  is
            'removed from inside this loop)
            IF a = (Last.Match.Length - 1) THEN
                FindString R
            ELSE
                MakeString R
            END IF
        NEXT
        FOR a = a TO Last.Match.Length - 1
            'this loop is active when no more characters are available
            'from the input stream
            'Kill string at S, not sure if this is needed because
            'we're  not  storing any characters in its place. I see
            'no reason to do it,   but  this  is one of those little
            'quirks that all LZSS implementations I've seen have... ?

            DeleteString S
            S = (S + 1) AND (BufferSize - 1)
            R = (R + 1) AND (BufferSize - 1)
            LookAheadLength = LookAheadLength - 1
            IF LookAheadLength THEN
                IF a = (Last.Match.Length - 1) THEN
                    FindString R
                ELSE
'Continued on page 3

--- MsgToss 2.0b
 * Origin: Computer Co-Op - Voorhees, NJ | Ted Hare (1:266/29)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #7268
 Date:    12-27-92 06:21 (Public)
 From:    RICH GELDREICH
 To:      ALL
 Subject: Bload Compressor/3
────────────────────────────────────────────────────────────────────────────────
'Page 3 of ENCODE13.BAS begins here.
                    MakeString R
                END IF

                'Limit  match  length  because the look ahead buffer
                'is growing smaller.   This is another little oddity
                'I've seen amoung the LZSS compressors,  they all do
                'this check outside this  loop  before they output a
                'character/match token...    There's  no  reason  to
                'check  outside  the  loop because the string search
                'function always  limits  the  match  length  to the
                'look ahead buffer's size.   We only check when  the
                'look ahead buffer starts to get smaller.

                IF Match.Length > LookAheadLength THEN
                    Match.Length = LookAheadLength
                END IF
            END IF
        NEXT
    LOOP WHILE LookAheadLength 'loop while still more chars to encode
    OutputEOF
    WriteFlush
    'get (compressed size)-header
    a& = LOF(1) - 7: SCREEN 0: WIDTH 80
    IF a& > 64000 THEN
        PRINT "Image could not be compressed."
        CLOSE #1: KILL F$
    ELSE
        PRINT "Image compressed to"; a&; "bytes."
        IF a& > 32767 THEN a& = a& - 65536
        'store the compressed size so BLOAD loads everything in
        a = a&: PUT #1, 6, a: CLOSE #1
    END IF
END SUB

'Deletes the string at S from the linked list pool.
SUB DeleteString (BYVAL S)
    NextCell = NextCell(S): LastCell = LastCell(S)
    NextCell(LastCell) = NextCell: LastCell(NextCell) = LastCell
    NextCell(S) = Null
END SUB

'Attempts to find a match at R+1 that is larger than the match found
'at R, to get rid of some of the encoder's "greedy" characteristics.
FUNCTION FindAlternate (BYVAL R, BYVAL MatchLength)
    B1 = RingBuffer(R): B2 = RingBuffer(R + 1): B3 = RingBuffer(R + 2)
    'hash out the first three characters of the string to locate
    P = (BufferSize + 1) + ((B1 * 14096& XOR B2 * 77 XOR B3) MOD _
HashSize)
    MatchChar = RingBuffer(R + MatchLength)
    FOR x = 1 TO MaxCompares
        P = NextCell(P) 'traverse linked list P for a match
        'if we struck bottom then search failed
        IF P = Null THEN FindAlternate = False: EXIT FUNCTION
        'compare string P to string R
        IF RingBuffer(P) = B1 AND RingBuffer(P + 1) = B2 AND RingBuffer_
(P + 2) = B3 AND RingBuffer(P + MatchLength) = MatchChar THEN
            FOR SearchLength = 3 TO (MaxMatch - 1) - 1
                IF RingBuffer(R + SearchLength) <> RingBuffer(P + _
SearchLength) THEN EXIT FOR
            NEXT
            'if we find a longer match then exit with success
            IF SearchLength > MatchLength THEN FindAlternate = True: _
EXIT FUNCTION
        END IF
    NEXT
    FindAlternate = False
END FUNCTION

'Attempts  to  locate  a  match  in the linked list pool for  R. Most
'other LZ77/LZSS  implementations  I've  seen  use  a  binary tree to
'locate string matches.   In this implementation,  I use  a  pool  of
'linked  lists to locate strings.   Each linked list contains strings
'which all  start  with the  same 3 characters. (Well, usually. Since
'hash collisions can occur,  sometimes  a linked list contains two or
'more different strings.   This isn't cool,  and can't be  eliminated
'unless  another approach to collision handling is used.)
'
'    To locate a string,  its linked list is located through a simple
'hashing formula(which was home brewed,  BTW,   so it may not be that
'optimal),  and then each string in the list is compared against  our
'target  string until we either find a string which matches perfectly
'or the "bombout" variable is decremented to zero.   The bombout rate
'defines the number of string  compares  which may be performed until
'the algorithm stops searching and settles with what it  has.    This
'decreases  compression  slightly,  but greatly increases compression
'speed,  especially when  the  input  stream  contains  large runs of
'repeated data.   (ARJ adjusts its bombout  rate  with  command  line
'options:   options  -m4  to  -m0 vary the number of compares it does
'against its string directionary,  therefore "dialing" in compression
'speed  vs.    compression  ratio.    PKZIP  1.93a  does  this  also.
'Normally, PKZIP 1.93a will set its bombout rate to 50 compares.  The
'Continued on page 4

--- MsgToss 2.0b
 * Origin: Computer Co-Op - Voorhees, NJ | Ted Hare (1:266/29)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #7269
 Date:    12-27-92 06:22 (Public)
 From:    RICH GELDREICH
 To:      ALL
 Subject: Bload Compressor/4
────────────────────────────────────────────────────────────────────────────────
'Page 4 of ENCODE13.BAS begins here.
'-s option brings this down to 10-7 compares(can't remember exactly),
'and  the -ex option increases the  bombout  rate  to  500  compares.
'Obviously, the -ex option slows down PKZIP 1.93a  because it can  do
'up to ten times more string compares than usual.)
'
'    One optimization that I have not seen anywhere yet speeds up the
'string  search  by  skipping  strings which can't possibly be larger
'than the largest string found up to that point...
'
'    For  instance,   let's  say we are searching for the string "the
'president eats peanuts".   Let's  also  say  the largest match we've
'found so far is "the president ", or 14 characters.  The next string
'to  compare  against  our target is "the president finds coolness in
'compression".  Since the whole point of searching is to look for the
'largest match, there's no use in doing a whole string compare if the
'match will be smaller/equal to  our current match.   A quick compare
'of the character that must match for the match length to  be  larger
'will  tell  us  if  the  string  *may* be larger.   If the character
'matches,  we must do the compare.   If it doesn't,  then there is no
'use in doing the string compare because the match cannot possibly be
'longer.   Since the 15th character of our target string is "e",  and
'the 15th character of our search string is "f",  it can instantly be
'discarded because the  match  cannot  possibly  be  larger  than  14
'characters.   This especially speeds up the search when large string
'matches  are found in the input stream(such as in text files).   And
'since the optimization is relatively trivial, it shouldn't slow down
'the string search loop much  at  all  when  input stream is not very
'compressable.
'
'   Finally,  using the linked list pool to find string matches makes
'finding the  closest  AND  longest  match  very  simple(finding  the
'closest  match  aids  entropy encoding in attaining more compression
'because it can  favor  close  matches  over  far  ones).   Since new
'strings are always inserted as the first string in its  pool,    the
'entire  list is already sorted in order of distance from our current
'position in the ring buffer.
SUB FindString (BYVAL R)
    B1 = RingBuffer(R): B2 = RingBuffer(R + 1): B3 = RingBuffer(R + 2)
    'hash the first 3 characters of the string to find
    LinkHead = (BufferSize + 1) + ((B1 * 14096& XOR B2 * 77 XOR B3) _
MOD HashSize)
    Match.Length = 0: MatchChar = B1: P = LinkHead
    FOR x = 1 TO MaxCompares 'MaxCompares is the bombout rate
        'traverse linked list P for match
        P = NextCell(P): IF P = Null THEN EXIT FOR
        'If first 3 characters match, and the character at
        'P+MatchLength=R+MatchLength, then compare strings.
        IF RingBuffer(P) = B1 AND RingBuffer(P + 1) = B2 AND RingBuffer_
(P + 2) = B3 AND RingBuffer(P + Match.Length) = MatchChar THEN
            FOR SearchLength = 3 TO (MaxMatch - 1) - 1
                IF RingBuffer(R + SearchLength) <> RingBuffer(P + _
SearchLength) THEN EXIT FOR
            NEXT
            'if matchsize=maxmatch then take it and run
            '(MaxMatch-1) because our look ahead buffer is one
            'character longer than the maximum match length.
            IF SearchLength >= (MaxMatch - 1) THEN
                Match.Length = (MaxMatch - 1)
                Match.Position = P
                EXIT FOR
            END IF
            'if we find a longer match then take it
            IF SearchLength > Match.Length THEN
                Match.Length = SearchLength
                Match.Position = P
                MatchChar = RingBuffer(R + Match.Length)
            END IF
        END IF
    NEXT
    'make the new string the first entry in its linked list pool
    'so we always find the closest match
    a = NextCell(LinkHead): NextCell(LinkHead) = R
    LastCell(a) = R: LastCell(R) = LinkHead: NextCell(R) = a
    'Attempt to find a longer match at R+1. If there is a longer
    'match, then set the match length to zero so the current match
    'is ignored.
    IF (Match.Length <> 0) AND (Match.Length <> (MaxMatch - 1)) THEN
        IF FindAlternate(R + 1, Match.Length) THEN Match.Length = 0
    END IF
END SUB

'Returns one pixel from the display.
FUNCTION GetPixel
    GetPixel = POINT(xp, yp): xp = xp + 1
    IF xp > xh THEN
        LINE (xl, yp)-(xh, yp), 0
        xp = xl: yp = yp + 1: DoneFlag = yp > yh
    END IF
END FUNCTION

'Initializes the linked list pool arrays
'Continued on page 5

--- MsgToss 2.0b
 * Origin: Computer Co-Op - Voorhees, NJ | Ted Hare (1:266/29)


------------------------------------------------------------------------
  The QuickBASIC Scrapbook

  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------

    That's it! Thank you for reading The QuickBASIC Scrapbook.



    Comments:

     Messages captured using Harvey Parisien's OFFLINE v1.50.

     The QuickBASIC Scrapbook is Copyright 1992 by Quauntum Software.
                           All Rights Reserved.